[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 8af2641: Add lisp/jsonrpc.el
|
From: |
João Távora |
|
Subject: |
[Emacs-diffs] master 8af2641: Add lisp/jsonrpc.el |
|
Date: |
Sat, 30 Jun 2018 14:46:28 -0400 (EDT) |
branch: master
commit 8af26410a91c3c9679bb0281ddd71f0dd77ec97c
Author: João Távora <address@hidden>
Commit: João Távora <address@hidden>
Add lisp/jsonrpc.el
* doc/lispref/text.texi (Text): Add JSONRPC.
(JSONRPC): New node.
* etc/NEWS (New Modes and Packages in Emacs 27.1): Mention jsonrpc.el
* lisp/jsonrpc.el: New file.
* test/lisp/jsonrpc-tests.el: New file.
---
doc/lispref/text.texi | 187 +++++++++++++
etc/NEWS | 9 +
lisp/jsonrpc.el | 649 +++++++++++++++++++++++++++++++++++++++++++++
test/lisp/jsonrpc-tests.el | 240 +++++++++++++++++
4 files changed, 1085 insertions(+)
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 94cd87a..5e86010 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -62,6 +62,7 @@ the character after point.
* GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS.
* Parsing HTML/XML:: Parsing HTML and XML.
* Parsing JSON:: Parsing and generating JSON values.
+* JSONRPC:: JSON Remote Procedure Call protocol
* Atomic Changes:: Installing several buffer changes atomically.
* Change Hooks:: Supplying functions to be run when text is changed.
@end menu
@@ -5132,6 +5133,192 @@ doesn't move point. The arguments @var{args} are
interpreted as in
@code{json-parse-string}.
@end defun
address@hidden JSONRPC
address@hidden JSONRPC communication
address@hidden JSON remote procedure call protocol
+
+The @code{jsonrpc} library implements the @acronym{JSONRPC}
+specification, version 2.0, as it is described in
address@hidden://www.jsonrpc.org/}. As the name suggests, JSONRPC is a
+generic @code{Remote Procedure Call} protocol designed around
address@hidden objects, which you can convert to and from Lisp objects
+(@pxref{Parsing JSON}).
+
address@hidden JSONRPC Overview
address@hidden Overview
+
+Quoting from the @uref{http://www.jsonrpc.org/, spec}, JSONRPC "is
+transport agnostic in that the concepts can be used within the same
+process, over sockets, over http, or in many various message passing
+environments."
+
+To model this agnosticism, the @code{jsonrpc} library uses objects of
+a @code{jsonrpc-connection} class, which represent a connection the
+remote JSON endpoint (for details on Emacs's object system,
address@hidden,EIEIO,,eieio,EIEIO}). In modern object-oriented parlance,
+this class is ``abstract'', i.e. the actual class of a useful
+connection object used is always a subclass of it. Nevertheless, we
+can define two distinct API's around the @code{jsonrpc-connection}
+class:
+
address@hidden
+
address@hidden A user interface for building JSONRPC applications
+
+In this scenario, the JSONRPC application instantiates
address@hidden objects of one of its concrete subclasses
+using @code{make-instance}. To initiate a contact to the remote
+endpoint, the JSONRPC application passes this object to the functions
address@hidden'}, @code{jsonrpc-request} and
address@hidden For handling remotely initiated
+contacts, which generally come in asynchronously, the instantiation
+should include @code{:request-dispatcher} and
address@hidden:notification-dispatcher} initargs, which are both functions of
+3 arguments: the connection object; a symbol naming the JSONRPC method
+invoked remotely; and a JSONRPC "params" object.
+
+The function passed as @code{:request-dispatcher} is responsible for
+handling the remote endpoint's requests, which expect a reply from the
+local endpoint (in this case, the program you're building). Inside
+that function, you may either return locally (normally) or non-locally
+(error). A local return value must be a Lisp object serializable as
+JSON (@pxref{Parsing JSON}). This determines a success response, and
+the object is forwarded to the server as the JSONRPC "result" object.
+A non-local return, achieved by calling the function
address@hidden, causes an error response to be sent to the
+server. The details of the accompanying JSONRPC "error" are filled
+out with whatever was passed to @code{jsonrpc-error}. A non-local
+return triggered by an unexpected error of any other type also causes
+an error response to be sent (unless you have set
address@hidden, in which case this should land you in the
+debugger, @pxref{Error Debugging}).
+
address@hidden A inheritance interface for building JSONRPC transport
implementations
+
+In this scenario, @code{jsonrpc-connection} is subclassed to implement
+a different underlying transport strategy (for details on how to
+subclass, @pxref{Inheritance,Inheritance,,eieio}). Users of the
+application-building interface can then instantiate objects of this
+concrete class (using the @code{make-instance} function) and connect
+to JSONRPC endpoints using that strategy.
+
+This API has mandatory and optional parts.
+
+To allow its users to initiate JSONRPC contacts (notifications or
+requests) or reply to endpoint requests, the method
address@hidden must be implemented for the subclass.
+
+Likewise, for handling the three types of remote contacts (requests,
+notifications and responses to local requests) the transport
+implementation must arrange for the function
address@hidden to be called after noticing a new
+JSONRPC message on the wire (whatever that "wire" may be).
+
+Finally, and optionally, the @code{jsonrpc-connection} subclass should
+implement @code{jsonrpc-shutdown} and @code{jsonrpc-running-p} if
+these concepts apply to the transport. If they do, then any system
+resources (e.g. processes, timers, etc..) used listen for messages on
+the wire should be released in @code{jsonrpc-shutdown}, i.e. they
+should only be needed while @code{jsonrpc-running-p} is non-nil.
+
address@hidden enumerate
+
address@hidden Process-based JSONRPC connections
address@hidden Process-based JSONRPC connections
+
+For convenience, the @code{jsonrpc} library comes built-in with a
address@hidden transport implementation that can
+talk to local subprocesses (using the standard input and standard
+output); or TCP hosts (using sockets); or any other remote endpoint
+that Emacs's process object can represent (@pxref{Processes}).
+
+Using this transport, the JSONRPC messages are encoded on the wire as
+plain text and prefaced by some basic HTTP-style enveloping headers,
+such as ``Content-Length''.
+
+For an example of an application using this transport scheme on top of
+JSONRPC, see the
address@hidden://microsoft.github.io/language-server-protocol/specification,
+Language Server Protocol}.
+
+Along with the mandatory @code{:request-dispatcher} and
address@hidden:notification-dispatcher} initargs, users of the
address@hidden class should pass the following
+initargs as keyword-value pairs to @code{make-instance}:
+
address@hidden @code
address@hidden :process
+Value must be a live process object or a function of no arguments
+producing one such object. If passed a process object, that is
+expected to contain an pre-established connection; otherwise, the
+function is called immediately after the object is made.
+
address@hidden :on-shutdown
+Value must be a function of a single argument, the
address@hidden object. The function is called
+after the underlying process object has been deleted (either
+deliberately by @code{jsonrpc-shutdown} or unexpectedly, because of
+some external cause).
address@hidden table
+
address@hidden JSONRPC JSON object format
address@hidden JSON object format
+
+JSON objects are exchanged as Lisp plists (@pxref{Parsing JSON}):
+JSON-compatible plists are handed to the dispatcher functions and,
+likewise, JSON-compatible plists should be given to
address@hidden, @code{jsonrpc-request} and
address@hidden
+
+To facilitate handling plists, this library make liberal use of
address@hidden library and suggests (but doesn't force) its clients to
+do the same. A macro @code{jsonrpc-lambda} can be used to create a
+lambda for destructuring a JSON-object like in this example:
+
address@hidden
+(jsonrpc-async-request
+ myproc :frobnicate `(:foo "trix")
+ :success-fn (jsonrpc-lambda (&key bar baz &allow-other-keys)
+ (message "Server replied back with %s and %s!"
+ bar baz))
+ :error-fn (jsonrpc-lambda (&key code message _data)
+ (message "Sadly, server reports %s: %s"
+ code message)))
address@hidden example
+
address@hidden JSONRPC deferred requests
address@hidden Deferred requests
+
+In many @acronym{RPC} situations, synchronization between the two
+communicating endpoints is a matter of correctly designing the RPC
+application: when synchronization is needed, requests (which are
+blocking) should be used; when it isn't, notifications should suffice.
+However, when Emacs acts as one of these endpoints, asynchronous
+events (e.g. timer- or process-related) may be triggered while there
+is still uncertainty about the state of the remote endpoint.
+Furthermore, acting on these events may only sometimes demand
+synchronization, depending on the event's specific nature.
+
+The @code{:deferred} keyword argument to @code{jsonrpc-request} and
address@hidden is designed to let the caller indicate
+that the specific request needs synchronization and its actual
+issuance may be delayed to the future, until some condition is
+satisfied. Specifying @code{:deferred} for a request doesn't mean it
address@hidden be delayed, only that it @emph{can} be. If the request
+isn't sent immediately, @code{jsonrpc} will make renewed efforts to
+send it at certain key times during communication, such as when
+receiving or sending other messages to the endpoint.
+
+Before any attempt to send the request, the application-specific
+conditions are checked. Since the @code{jsonrpc} library can't known
+what these conditions are, the programmer may use the
address@hidden generic function (@pxref{Generic
+Functions}) to specify them. The default method for this function
+returns @code{t}, but you can add overriding methods that return
address@hidden in some situations, based on the arguments passed to it,
+which are the @code{jsonrpc-connection} object (@pxref{JSONRPC
+Overview}) and whichever value you passed as the @code{:deferred}
+keyword argument.
@node Atomic Changes
@section Atomic Change Groups
diff --git a/etc/NEWS b/etc/NEWS
index f5332c0..63c59ae 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -579,6 +579,15 @@ This feature uses Tramp and works only on systems which
support GVFS,
i.e. GNU/Linux, roughly spoken. See the chapter "(tramp) Archive file
names" in the Tramp manual for full documentation of these facilities.
++++
+** New library for writing JSONRPC applications (https://jsonrpc.org)
+The 'jsonrpc' library enables writing Emacs Lisp applications that
+rely on this protocol. Since the protocol is designed to be
+transport-agnostic, the library provides an API to implement new
+transport strategies as well as a separate API to use them. A
+transport implementation for process-based communication, such as is
+used by the Language Server Protocol (LSP), is readily available.
+
* Incompatible Lisp Changes in Emacs 27.1
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
new file mode 100644
index 0000000..8cc853e
--- /dev/null
+++ b/lisp/jsonrpc.el
@@ -0,0 +1,649 @@
+;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: João Távora <address@hidden>
+;; Maintainer: João Távora <address@hidden>
+;; Keywords: processes, languages, extensions
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library implements the JSONRPC 2.0 specification as described
+;; in http://www.jsonrpc.org/. As the name suggests, JSONRPC is a
+;; generic Remote Procedure Call protocol designed around JSON
+;; objects. To learn how to write JSONRPC programs with this library,
+;; see Info node `(elisp)JSONRPC'."
+;;
+;; This library was originally extracted from eglot.el, an Emacs LSP
+;; client, which you should see for an example usage.
+;;
+;;; Code:
+
+(require 'cl-lib)
+(require 'json)
+(require 'eieio)
+(require 'subr-x)
+(require 'warnings)
+(require 'pcase)
+(require 'ert) ; to escape a `condition-case-unless-debug'
+(require 'array) ; xor
+
+
+;;; Public API
+;;;
+;;;###autoload
+(defclass jsonrpc-connection ()
+ ((name
+ :accessor jsonrpc-name
+ :initarg :name
+ :documentation "A name for the connection")
+ (-request-dispatcher
+ :accessor jsonrpc--request-dispatcher
+ :initform #'ignore
+ :initarg :request-dispatcher
+ :documentation "Dispatcher for remotely invoked requests.")
+ (-notification-dispatcher
+ :accessor jsonrpc--notification-dispatcher
+ :initform #'ignore
+ :initarg :notification-dispatcher
+ :documentation "Dispatcher for remotely invoked notifications.")
+ (last-error
+ :accessor jsonrpc-last-error
+ :documentation "Last JSONRPC error message received from endpoint.")
+ (-request-continuations
+ :initform (make-hash-table)
+ :accessor jsonrpc--request-continuations
+ :documentation "A hash table of request ID to continuation lambdas.")
+ (-events-buffer
+ :accessor jsonrpc--events-buffer
+ :documentation "A buffer pretty-printing the JSON-RPC RPC events")
+ (-deferred-actions
+ :initform (make-hash-table :test #'equal)
+ :accessor jsonrpc--deferred-actions
+ :documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\
+a saved DEFERRED `async-request' from BUF, to be sent not later\
+than TIMER as ID.")
+ (-next-request-id
+ :initform 0
+ :accessor jsonrpc--next-request-id
+ :documentation "Next number used for a request"))
+ :documentation "Base class representing a JSONRPC connection.
+The following initargs are accepted:
+
+:NAME (mandatory), a string naming the connection
+
+:REQUEST-DISPATCHER (optional), a function of three
+arguments (CONN METHOD PARAMS) for handling JSONRPC requests.
+CONN is a `jsonrpc-connection' object, method is a symbol, and
+PARAMS is a plist representing a JSON object. The function is
+expected to return a JSONRPC result, a plist of (:result
+RESULT) or signal an error of type `jsonrpc-error'.
+
+:NOTIFICATION-DISPATCHER (optional), a function of three
+arguments (CONN METHOD PARAMS) for handling JSONRPC
+notifications. CONN, METHOD and PARAMS are the same as in
+:REQUEST-DISPATCHER.")
+
+;;; API mandatory
+(cl-defgeneric jsonrpc-connection-send (conn &key id method params result
error)
+ "Send a JSONRPC message to connection CONN.
+ID, METHOD, PARAMS, RESULT and ERROR. ")
+
+;;; API optional
+(cl-defgeneric jsonrpc-shutdown (conn)
+ "Shutdown the JSONRPC connection CONN.")
+
+;;; API optional
+(cl-defgeneric jsonrpc-running-p (conn)
+ "Tell if the JSONRPC connection CONN is still running.")
+
+;;; API optional
+(cl-defgeneric jsonrpc-connection-ready-p (connection what)
+ "Tell if CONNECTION is ready for WHAT in current buffer.
+If it isn't, a request which was passed a value to the
+`:deferred' keyword argument will be deferred to the future.
+WHAT is whatever was passed the as the value to that argument.
+
+By default, all connections are ready for sending all requests
+immediately."
+ (:method (_s _what) ;; by default all connections are ready
+ t))
+
+
+;;; Convenience
+;;;
+(cl-defmacro jsonrpc-lambda (cl-lambda-list &body body)
+ (declare (indent 1) (debug (sexp &rest form)))
+ (let ((e (gensym "jsonrpc-lambda-elem")))
+ `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e))))
+
+(defun jsonrpc-events-buffer (connection)
+ "Get or create JSONRPC events buffer for CONNECTION."
+ (let* ((probe (jsonrpc--events-buffer connection))
+ (buffer (or (and (buffer-live-p probe)
+ probe)
+ (let ((buffer (get-buffer-create
+ (format "*%s events*"
+ (jsonrpc-name connection)))))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (read-only-mode t)
+ (setf (jsonrpc--events-buffer connection) buffer))
+ buffer))))
+ buffer))
+
+(defun jsonrpc-forget-pending-continuations (connection)
+ "Stop waiting for responses from the current JSONRPC CONNECTION."
+ (clrhash (jsonrpc--request-continuations connection)))
+
+(defun jsonrpc-connection-receive (connection message)
+ "Process MESSAGE just received from CONNECTION.
+This function will destructure MESSAGE and call the appropriate
+dispatcher in CONNECTION."
+ (cl-destructuring-bind (&key method id error params result _jsonrpc)
+ message
+ (let (continuations)
+ (jsonrpc--log-event connection message 'server)
+ (setf (jsonrpc-last-error connection) error)
+ (cond
+ (;; A remote request
+ (and method id)
+ (let* ((debug-on-error (and debug-on-error (not (ert-running-test))))
+ (reply
+ (condition-case-unless-debug _ignore
+ (condition-case oops
+ `(:result ,(funcall (jsonrpc--request-dispatcher
connection)
+ connection (intern method) params))
+ (jsonrpc-error
+ `(:error
+ (:code
+ ,(or (alist-get 'jsonrpc-error-code (cdr oops))
-32603)
+ :message ,(or (alist-get 'jsonrpc-error-message
+ (cdr oops))
+ "Internal error")))))
+ (error
+ `(:error (:code -32603 :message "Internal error"))))))
+ (apply #'jsonrpc--reply connection id reply)))
+ (;; A remote notification
+ method
+ (funcall (jsonrpc--notification-dispatcher connection)
+ connection (intern method) params))
+ (;; A remote response
+ (setq continuations
+ (and id (gethash id (jsonrpc--request-continuations
connection))))
+ (let ((timer (nth 2 continuations)))
+ (when timer (cancel-timer timer)))
+ (remhash id (jsonrpc--request-continuations connection))
+ (if error (funcall (nth 1 continuations) error)
+ (funcall (nth 0 continuations) result)))
+ (;; An abnormal situation
+ id (jsonrpc--warn "No continuation for id %s" id)))
+ (jsonrpc--call-deferred connection))))
+
+
+;;; Contacting the remote endpoint
+;;;
+(defun jsonrpc-error (&rest args)
+ "Error out with FORMAT and ARGS.
+If invoked inside a dispatcher function, this function is suitable
+for replying to the remote endpoint with an error message.
+
+ARGS can be of the form (FORMAT-STRING . MOREARGS) for replying
+with a -32603 error code and a message formed by formatting
+FORMAT-STRING with MOREARGS.
+
+Alternatively ARGS can be plist representing a JSONRPC error
+object, using the keywords `:code', `:message' and `:data'."
+ (if (stringp (car args))
+ (let ((msg
+ (apply #'format-message (car args) (cdr args))))
+ (signal 'jsonrpc-error
+ `(,msg
+ (jsonrpc-error-code . ,32603)
+ (jsonrpc-error-message . ,msg))))
+ (cl-destructuring-bind (&key code message data) args
+ (signal 'jsonrpc-error
+ `(,(format "[jsonrpc] error ")
+ (jsonrpc-error-code . ,code)
+ (jsonrpc-error-message . ,message)
+ (jsonrpc-error-data . ,data))))))
+
+(cl-defun jsonrpc-async-request (connection
+ method
+ params
+ &rest args
+ &key _success-fn _error-fn
+ _timeout-fn
+ _timeout _deferred)
+ "Make a request to CONNECTION, expecting a reply, return immediately.
+The JSONRPC request is formed by METHOD, a symbol, and PARAMS a
+JSON object.
+
+The caller can expect SUCCESS-FN or ERROR-FN to be called with a
+JSONRPC `:result' or `:error' object, respectively. If this
+doesn't happen after TIMEOUT seconds (defaults to
+`jsonrpc-request-timeout'), the caller can expect TIMEOUT-FN to be
+called with no arguments. The default values of SUCCESS-FN,
+ERROR-FN and TIMEOUT-FN simply log the events into
+`jsonrpc-events-buffer'.
+
+If DEFERRED is non-nil, maybe defer the request to a future time
+when the server is thought to be ready according to
+`jsonrpc-connection-ready-p' (which see). The request might
+never be sent at all, in case it is overridden in the meantime by
+a new request with identical DEFERRED and for the same buffer.
+However, in that situation, the original timeout is kept.
+
+Returns nil."
+ (apply #'jsonrpc--async-request-1 connection method params args)
+ nil)
+
+(cl-defun jsonrpc-request (connection method params &key deferred timeout)
+ "Make a request to CONNECTION, wait for a reply.
+Like `jsonrpc-async-request' for CONNECTION, METHOD and PARAMS,
+but synchronous, i.e. this function doesn't exit until anything
+interesting (success, error or timeout) happens. Furthermore, it
+only exits locally (returning the JSONRPC result object) if the
+request is successful, otherwise exit non-locally with an error
+of type `jsonrpc-error'.
+
+DEFERRED is passed to `jsonrpc-async-request', which see."
+ (let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer
+ (retval
+ (unwind-protect ; protect against user-quit, for example
+ (catch tag
+ (setq
+ id-and-timer
+ (jsonrpc--async-request-1
+ connection method params
+ :success-fn (lambda (result) (throw tag `(done ,result)))
+ :error-fn
+ (jsonrpc-lambda
+ (&key code message data)
+ (throw tag `(error (jsonrpc-error-code . ,code)
+ (jsonrpc-error-message . ,message)
+ (jsonrpc-error-data . ,data))))
+ :timeout-fn
+ (lambda ()
+ (throw tag '(error (jsonrpc-error-message . "Timed out"))))
+ :deferred deferred
+ :timeout timeout))
+ (while t (accept-process-output nil 30)))
+ (pcase-let* ((`(,id ,timer) id-and-timer))
+ (remhash id (jsonrpc--request-continuations connection))
+ (remhash (list deferred (current-buffer))
+ (jsonrpc--deferred-actions connection))
+ (when timer (cancel-timer timer))))))
+ (when (eq 'error (car retval))
+ (signal 'jsonrpc-error
+ (cons
+ (format "request id=%s failed:" (car id-and-timer))
+ (cdr retval))))
+ (cadr retval)))
+
+(cl-defun jsonrpc-notify (connection method params)
+ "Notify CONNECTION of something, don't expect a reply."
+ (jsonrpc-connection-send connection
+ :method method
+ :params params))
+
+(defconst jrpc-default-request-timeout 10
+ "Time in seconds before timing out a JSONRPC request.")
+
+
+;;; Specfic to `jsonrpc-process-connection'
+;;;
+;;;###autoload
+(defclass jsonrpc-process-connection (jsonrpc-connection)
+ ((-process
+ :initarg :process :accessor jsonrpc--process
+ :documentation "Process object wrapped by the this connection.")
+ (-expected-bytes
+ :accessor jsonrpc--expected-bytes
+ :documentation "How many bytes declared by server")
+ (-on-shutdown
+ :accessor jsonrpc--on-shutdown
+ :initform #'ignore
+ :initarg :on-shutdown
+ :documentation "Function run when the process dies."))
+ :documentation "A JSONRPC connection over an Emacs process.
+The following initargs are accepted:
+
+:PROCESS (mandatory), a live running Emacs process object or a
+function of no arguments producing one such object. The process
+represents either a pipe connection to locally running process or
+a stream connection to a network host. The remote endpoint is
+expected to understand JSONRPC messages with basic HTTP-style
+enveloping headers such as \"Content-Length:\".
+
+:ON-SHUTDOWN (optional), a function of one argument, the
+connection object, called when the process dies .")
+
+(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots)
+ (cl-call-next-method)
+ (let* ((proc (plist-get slots :process))
+ (proc (if (functionp proc) (funcall proc) proc))
+ (buffer (get-buffer-create (format "*%s output*" (process-name
proc))))
+ (stderr (get-buffer-create (format "*%s stderr*" (process-name
proc)))))
+ (setf (jsonrpc--process conn) proc)
+ (set-process-buffer proc buffer)
+ (process-put proc 'jsonrpc-stderr stderr)
+ (set-process-filter proc #'jsonrpc--process-filter)
+ (set-process-sentinel proc #'jsonrpc--process-sentinel)
+ (with-current-buffer (process-buffer proc)
+ (set-marker (process-mark proc) (point-min))
+ (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc))
+ (process-put proc 'jsonrpc-connection conn)))
+
+(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
+ &rest args
+ &key
+ _id
+ method
+ _params
+ _result
+ _error
+ _partial)
+ "Send MESSAGE, a JSON object, to CONNECTION."
+ (when method
+ (plist-put args :method
+ (cond ((keywordp method) (substring (symbol-name method) 1))
+ ((and method (symbolp method)) (symbol-name method)))))
+ (let* ( (message `(:jsonrpc "2.0" ,@args))
+ (json (jsonrpc--json-encode message))
+ (headers
+ `(("Content-Length" . ,(format "%d" (string-bytes json)))
+ ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8")
+ )))
+ (process-send-string
+ (jsonrpc--process connection)
+ (cl-loop for (header . value) in headers
+ concat (concat header ": " value "\r\n") into header-section
+ finally return (format "%s\r\n%s" header-section json)))
+ (jsonrpc--log-event connection message 'client)))
+
+(defun jsonrpc-process-type (conn)
+ "Return the `process-type' of JSONRPC connection CONN."
+ (process-type (jsonrpc--process conn)))
+
+(cl-defmethod jsonrpc-running-p ((conn jsonrpc-process-connection))
+ "Return non-nil if JSONRPC connection CONN is running."
+ (process-live-p (jsonrpc--process conn)))
+
+(cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection))
+ "Shutdown the JSONRPC connection CONN."
+ (cl-loop
+ with proc = (jsonrpc--process conn)
+ do
+ (delete-process proc)
+ (accept-process-output nil 0.1)
+ while (not (process-get proc 'jsonrpc-sentinel-done))
+ do (jsonrpc--warn
+ "Sentinel for %s still hasn't run, deleting it!" proc)))
+
+(defun jsonrpc-stderr-buffer (conn)
+ "Get CONN's standard error buffer, if any."
+ (process-get (jsonrpc--process conn) 'jsonrpc-stderr))
+
+
+;;; Private stuff
+;;;
+(define-error 'jsonrpc-error "jsonrpc-error")
+
+(defun jsonrpc--json-read ()
+ "Read JSON object in buffer, move point to end of buffer."
+ ;; TODO: I guess we can make these macros if/when jsonrpc.el
+ ;; goes into Emacs core.
+ (cond ((fboundp 'json-parse-buffer) (json-parse-buffer
+ :object-type 'plist
+ :null-object nil
+ :false-object :json-false))
+ (t (let ((json-object-type 'plist))
+ (json-read)))))
+
+(defun jsonrpc--json-encode (object)
+ "Encode OBJECT into a JSON string."
+ (cond ((fboundp 'json-serialize) (json-serialize
+ object
+ :false-object :json-false
+ :null-object nil))
+ (t (let ((json-false :json-false)
+ (json-null nil))
+ (json-encode object)))))
+
+(cl-defun jsonrpc--reply (connection id &key (result nil result-supplied-p)
error)
+ "Reply to CONNECTION's request ID with RESULT or ERROR."
+ (jsonrpc-connection-send connection :id id :result result :error error))
+
+(defun jsonrpc--call-deferred (connection)
+ "Call CONNECTION's deferred actions, who may again defer themselves."
+ (when-let ((actions (hash-table-values (jsonrpc--deferred-actions
connection))))
+ (jsonrpc--debug connection `(:maybe-run-deferred ,(mapcar #'caddr
actions)))
+ (mapc #'funcall (mapcar #'car actions))))
+
+(defun jsonrpc--process-sentinel (proc change)
+ "Called when PROC undergoes CHANGE."
+ (let ((connection (process-get proc 'jsonrpc-connection)))
+ (jsonrpc--debug connection `(:message "Connection state changed" :change
,change))
+ (when (not (process-live-p proc))
+ (with-current-buffer (jsonrpc-events-buffer connection)
+ (let ((inhibit-read-only t))
+ (insert "\n----------b---y---e---b---y---e----------\n")))
+ ;; Cancel outstanding timers
+ (maphash (lambda (_id triplet)
+ (pcase-let ((`(,_success ,_error ,timeout) triplet))
+ (when timeout (cancel-timer timeout))))
+ (jsonrpc--request-continuations connection))
+ (unwind-protect
+ ;; Call all outstanding error handlers
+ (maphash (lambda (_id triplet)
+ (pcase-let ((`(,_success ,error ,_timeout) triplet))
+ (funcall error `(:code -1 :message "Server died"))))
+ (jsonrpc--request-continuations connection))
+ (jsonrpc--message "Server exited with status %s" (process-exit-status
proc))
+ (process-put proc 'jsonrpc-sentinel-done t)
+ (delete-process proc)
+ (funcall (jsonrpc--on-shutdown connection) connection)))))
+
+(defun jsonrpc--process-filter (proc string)
+ "Called when new data STRING has arrived for PROC."
+ (when (buffer-live-p (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (let* ((inhibit-read-only t)
+ (connection (process-get proc 'jsonrpc-connection))
+ (expected-bytes (jsonrpc--expected-bytes connection)))
+ ;; Insert the text, advancing the process marker.
+ ;;
+ (save-excursion
+ (goto-char (process-mark proc))
+ (insert string)
+ (set-marker (process-mark proc) (point)))
+ ;; Loop (more than one message might have arrived)
+ ;;
+ (unwind-protect
+ (let (done)
+ (while (not done)
+ (cond
+ ((not expected-bytes)
+ ;; Starting a new message
+ ;;
+ (setq expected-bytes
+ (and (search-forward-regexp
+ "\\(?:.*: .*\r\n\\)*Content-Length: \
+*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
+ (+ (point) 100)
+ t)
+ (string-to-number (match-string 1))))
+ (unless expected-bytes
+ (setq done :waiting-for-new-message)))
+ (t
+ ;; Attempt to complete a message body
+ ;;
+ (let ((available-bytes (- (position-bytes (process-mark
proc))
+ (position-bytes (point)))))
+ (cond
+ ((>= available-bytes
+ expected-bytes)
+ (let* ((message-end (byte-to-position
+ (+ (position-bytes (point))
+ expected-bytes))))
+ (unwind-protect
+ (save-restriction
+ (narrow-to-region (point) message-end)
+ (let* ((json-message
+ (condition-case-unless-debug oops
+ (jsonrpc--json-read)
+ (error
+ (jsonrpc--warn "Invalid JSON: %s %s"
+ (cdr oops)
(buffer-string))
+ nil))))
+ (when json-message
+ ;; Process content in another
+ ;; buffer, shielding proc buffer from
+ ;; tamper
+ (with-temp-buffer
+ (jsonrpc-connection-receive connection
+
json-message)))))
+ (goto-char message-end)
+ (delete-region (point-min) (point))
+ (setq expected-bytes nil))))
+ (t
+ ;; Message is still incomplete
+ ;;
+ (setq done
:waiting-for-more-bytes-in-this-message))))))))
+ ;; Saved parsing state for next visit to this filter
+ ;;
+ (setf (jsonrpc--expected-bytes connection) expected-bytes))))))
+
+(cl-defun jsonrpc--async-request-1 (connection
+ method
+ params
+ &rest args
+ &key success-fn error-fn timeout-fn
+ (timeout jrpc-default-request-timeout)
+ (deferred nil))
+ "Does actual work for `jsonrpc-async-request'.
+
+Return a list (ID TIMER). ID is the new request's ID, or nil if
+the request was deferred. TIMER is a timer object set (or nil, if
+TIMEOUT is nil)."
+ (pcase-let* ((buf (current-buffer)) (point (point))
+ (`(,_ ,timer ,old-id)
+ (and deferred (gethash (list deferred buf)
+ (jsonrpc--deferred-actions
connection))))
+ (id (or old-id (cl-incf (jsonrpc--next-request-id connection))))
+ (make-timer
+ (lambda ( )
+ (when timeout
+ (run-with-timer
+ timeout nil
+ (lambda ()
+ (remhash id (jsonrpc--request-continuations connection))
+ (remhash (list deferred buf)
+ (jsonrpc--deferred-actions connection))
+ (if timeout-fn (funcall timeout-fn)
+ (jsonrpc--debug
+ connection `(:timed-out ,method :id ,id
+ :params ,params)))))))))
+ (when deferred
+ (if (jsonrpc-connection-ready-p connection deferred)
+ ;; Server is ready, we jump below and send it immediately.
+ (remhash (list deferred buf) (jsonrpc--deferred-actions connection))
+ ;; Otherwise, save in `eglot--deferred-actions' and exit non-locally
+ (unless old-id
+ (jsonrpc--debug connection `(:deferring ,method :id ,id :params
+ ,params)))
+ (puthash (list deferred buf)
+ (list (lambda ()
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (save-excursion (goto-char point)
+ (apply #'jsonrpc-async-request
+ connection
+ method params args)))))
+ (or timer (setq timer (funcall make-timer))) id)
+ (jsonrpc--deferred-actions connection))
+ (cl-return-from jsonrpc--async-request-1 (list id timer))))
+ ;; Really send it
+ ;;
+ (jsonrpc-connection-send connection
+ :id id
+ :method method
+ :params params)
+ (puthash id
+ (list (or success-fn
+ (jsonrpc-lambda (&rest _ignored)
+ (jsonrpc--debug
+ connection (list :message "success ignored"
+ :id id))))
+ (or error-fn
+ (jsonrpc-lambda (&key code message &allow-other-keys)
+ (jsonrpc--debug
+ connection (list
+ :message
+ (format "error ignored, status set (%s)"
+ message)
+ :id id :error code))))
+ (setq timer (funcall make-timer)))
+ (jsonrpc--request-continuations connection))
+ (list id timer)))
+
+(defun jsonrpc--message (format &rest args)
+ "Message out with FORMAT with ARGS."
+ (message "[jsonrpc] %s" (apply #'format format args)))
+
+(defun jsonrpc--debug (server format &rest args)
+ "Debug message for SERVER with FORMAT and ARGS."
+ (jsonrpc--log-event
+ server (if (stringp format)`(:message ,(format format args)) format)))
+
+(defun jsonrpc--warn (format &rest args)
+ "Warning message with FORMAT and ARGS."
+ (apply #'jsonrpc--message (concat "(warning) " format) args)
+ (let ((warning-minimum-level :error))
+ (display-warning 'jsonrpc
+ (apply #'format format args)
+ :warning)))
+
+(defun jsonrpc--log-event (connection message &optional type)
+ "Log a JSONRPC-related event.
+CONNECTION is the current connection. MESSAGE is a JSON-like
+plist. TYPE is a symbol saying if this is a client or server
+originated."
+ (with-current-buffer (jsonrpc-events-buffer connection)
+ (cl-destructuring-bind (&key method id error &allow-other-keys) message
+ (let* ((inhibit-read-only t)
+ (subtype (cond ((and method id) 'request)
+ (method 'notification)
+ (id 'reply)
+ (t 'message)))
+ (type
+ (concat (format "%s" (or type 'internal))
+ (if type
+ (format "-%s" subtype)))))
+ (goto-char (point-max))
+ (let ((msg (format "%s%s%s %s:\n%s\n"
+ type
+ (if id (format " (id:%s)" id) "")
+ (if error " ERROR" "")
+ (current-time-string)
+ (pp-to-string message))))
+ (when error
+ (setq msg (propertize msg 'face 'error)))
+ (insert-before-markers msg))))))
+
+(provide 'jsonrpc)
+;;; jsonrpc.el ends here
diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el
new file mode 100644
index 0000000..9395ab6
--- /dev/null
+++ b/test/lisp/jsonrpc-tests.el
@@ -0,0 +1,240 @@
+;;; jsonrpc-tests.el --- tests for jsonrpc.el -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: João Távora <address@hidden>
+;; Maintainer: João Távora <address@hidden>
+;; Keywords: tests
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; About "deferred" tests, `jsonrpc--test-client' has a flag that we
+;; test this flag in the this `jsonrpc-connection-ready-p' API method.
+;; It holds any `jsonrpc-request's and `jsonrpc-async-request's
+;; explicitly passed `:deferred'. After clearing the flag, the held
+;; requests are actually sent to the server in the next opportunity
+;; (when receiving or sending something to the server).
+
+;;; Code:
+
+(require 'ert)
+(require 'jsonrpc)
+(require 'eieio)
+
+(defclass jsonrpc--test-endpoint (jsonrpc-process-connection)
+ ((scp :accessor jsonrpc--shutdown-complete-p)))
+
+(defclass jsonrpc--test-client (jsonrpc--test-endpoint)
+ ((hold-deferred :initform t :accessor jsonrpc--hold-deferred)))
+
+(cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body)
+ (declare (indent 1) (debug t))
+ (let ((server (gensym "server-")) (listen-server (gensym "listen-server-")))
+ `(let* (,server
+ (,listen-server
+ (make-network-process
+ :name "Emacs RPC server" :server t :host "localhost"
+ :service 0
+ :log (lambda (_server client _message)
+ (setq ,server
+ (make-instance
+ 'jsonrpc--test-endpoint
+ :name (process-name client)
+ :process client
+ :request-dispatcher
+ (lambda (_endpoint method params)
+ (unless (memq method '(+ - * / vconcat append
+ sit-for ignore))
+ (signal 'jsonrpc-error
+ `((jsonrpc-error-message
+ . "Sorry, this isn't allowed")
+ (jsonrpc-error-code . -32601))))
+ (apply method (append params nil)))
+ :on-shutdown
+ (lambda (conn)
+ (setf (jsonrpc--shutdown-complete-p conn)
t)))))))
+ (,endpoint-sym (make-instance
+ 'jsonrpc--test-client
+ "Emacs RPC client"
+ :process
+ (open-network-stream "JSONRPC test tcp endpoint"
+ nil "localhost"
+ (process-contact
,listen-server
+ :service))
+ :on-shutdown
+ (lambda (conn)
+ (setf (jsonrpc--shutdown-complete-p conn) t)))))
+ (unwind-protect
+ (progn
+ (cl-assert ,endpoint-sym)
+ ,@body
+ (kill-buffer (jsonrpc--events-buffer ,endpoint-sym))
+ (when ,server
+ (kill-buffer (jsonrpc--events-buffer ,server))))
+ (unwind-protect
+ (jsonrpc-shutdown ,endpoint-sym)
+ (unwind-protect
+ (jsonrpc-shutdown ,server)
+ (cl-loop do (delete-process ,listen-server)
+ while (progn (accept-process-output nil 0.1)
+ (process-live-p ,listen-server))
+ do (jsonrpc--message
+ "test listen-server is still running,
waiting"))))))))
+
+(ert-deftest returns-3 ()
+ "A basic test for adding two numbers in our test RPC."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (should (= 3 (jsonrpc-request conn '+ [1 2])))))
+
+(ert-deftest errors-with--32601 ()
+ "Errors with -32601"
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (condition-case err
+ (progn
+ (jsonrpc-request conn 'delete-directory "~/tmp")
+ (ert-fail "A `jsonrpc-error' should have been signalled!"))
+ (jsonrpc-error
+ (should (= -32601 (cdr (assoc 'jsonrpc-error-code (cdr err)))))))))
+
+(ert-deftest signals-an--32603-JSONRPC-error ()
+ "Signals an -32603 JSONRPC error."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (condition-case err
+ (progn
+ (jsonrpc-request conn '+ ["a" 2])
+ (ert-fail "A `jsonrpc-error' should have been signalled!"))
+ (jsonrpc-error
+ (should (= -32603 (cdr (assoc 'jsonrpc-error-code (cdr err)))))))))
+
+(ert-deftest times-out ()
+ "Request for 3-sec sit-for with 1-sec timeout times out."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (should-error
+ (jsonrpc-request conn 'sit-for [3] :timeout 1))))
+
+(ert-deftest doesnt-time-out ()
+ :tags '(:expensive-test)
+ "Request for 1-sec sit-for with 2-sec timeout succeeds."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (jsonrpc-request conn 'sit-for [1] :timeout 2)))
+
+(ert-deftest stretching-it-but-works ()
+ "Vector of numbers or vector of vector of numbers are serialized."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ ;; (vconcat [1 2 3] [3 4 5]) => [1 2 3 3 4 5] which can be
+ ;; serialized.
+ (should (equal
+ [1 2 3 3 4 5]
+ (jsonrpc-request conn 'vconcat [[1 2 3] [3 4 5]])))))
+
+(ert-deftest json-el-cant-serialize-this ()
+ "Can't serialize a response that is half-vector/half-list."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (should-error
+ ;; (append [1 2 3] [3 4 5]) => (1 2 3 . [3 4 5]), which can't be
+ ;; serialized
+ (jsonrpc-request conn 'append [[1 2 3] [3 4 5]]))))
+
+(cl-defmethod jsonrpc-connection-ready-p
+ ((conn jsonrpc--test-client) what)
+ (and (cl-call-next-method)
+ (or (not (string-match "deferred" what))
+ (not (jsonrpc--hold-deferred conn)))))
+
+(ert-deftest deferred-action-toolate ()
+ :tags '(:expensive-test)
+ "Deferred request fails because noone clears the flag."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (should-error
+ (jsonrpc-request conn '+ [1 2]
+ :deferred "deferred-testing" :timeout 0.5)
+ :type 'jsonrpc-error)
+ (should
+ (= 3 (jsonrpc-request conn '+ [1 2]
+ :timeout 0.5)))))
+
+(ert-deftest deferred-action-intime ()
+ :tags '(:expensive-test)
+ "Deferred request barely makes it after event clears a flag."
+ ;; Send an async request, which returns immediately. However the
+ ;; success fun which sets the flag only runs after some time.
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (jsonrpc-async-request conn
+ 'sit-for [0.5]
+ :success-fn
+ (lambda (_result)
+ (setf (jsonrpc--hold-deferred conn) nil)))
+ ;; Now wait for an answer to this request, which should be sent as
+ ;; soon as the previous one is answered.
+ (should
+ (= 3 (jsonrpc-request conn '+ [1 2]
+ :deferred "deferred"
+ :timeout 1)))))
+
+(ert-deftest deferred-action-complex-tests ()
+ :tags '(:expensive-test)
+ "Test a more complex situation with deferred requests."
+ (jsonrpc--with-emacsrpc-fixture (conn)
+ (let (n-deferred-1
+ n-deferred-2
+ second-deferred-went-through-p)
+ ;; This returns immediately
+ (jsonrpc-async-request
+ conn
+ 'sit-for [0.1]
+ :success-fn
+ (lambda (_result)
+ ;; this only gets runs after the "first deferred" is stashed.
+ (setq n-deferred-1
+ (hash-table-count (jsonrpc--deferred-actions conn)))))
+ (should-error
+ ;; This stashes the request and waits. It will error because
+ ;; no-one clears the "hold deferred" flag.
+ (jsonrpc-request conn 'ignore ["first deferred"]
+ :deferred "first deferred"
+ :timeout 0.5)
+ :type 'jsonrpc-error)
+ ;; The error means the deferred actions stash is now empty
+ (should (zerop (hash-table-count (jsonrpc--deferred-actions conn))))
+ ;; Again, this returns immediately.
+ (jsonrpc-async-request
+ conn
+ 'sit-for [0.1]
+ :success-fn
+ (lambda (_result)
+ ;; This gets run while "third deferred" below is waiting for
+ ;; a reply. Notice that we clear the flag in time here.
+ (setq n-deferred-2 (hash-table-count (jsonrpc--deferred-actions
conn)))
+ (setf (jsonrpc--hold-deferred conn) nil)))
+ ;; This again stashes a request and returns immediately.
+ (jsonrpc-async-request conn 'ignore ["second deferred"]
+ :deferred "second deferred"
+ :timeout 1
+ :success-fn
+ (lambda (_result)
+ (setq second-deferred-went-through-p t)))
+ ;; And this also stashes a request, but waits. Eventually the
+ ;; flag is cleared in time and both requests go through.
+ (jsonrpc-request conn 'ignore ["third deferred"]
+ :deferred "third deferred"
+ :timeout 1)
+ (should second-deferred-went-through-p)
+ (should (eq 1 n-deferred-1))
+ (should (eq 2 n-deferred-2))
+ (should (eq 0 (hash-table-count (jsonrpc--deferred-actions conn)))))))
+
+(provide 'jsonrpc-tests)
+;;; jsonrpc-tests.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 8af2641: Add lisp/jsonrpc.el,
João Távora <=