procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add lisp/jsonrpc.el

Browse source 
* 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.
This commit is contained in:
João Távora 2018-06-30 19:06:43 +01:00
parent 852395bab7
commit 8af26410a9
4 changed files with 1085 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

187
doc/lispref/text.texi
View file

@ -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
@node JSONRPC
@section JSONRPC communication
@cindex JSON remote procedure call protocol
The @code{jsonrpc} library implements the @acronym{JSONRPC}
specification, version 2.0, as it is described in
@uref{http://www.jsonrpc.org/}. As the name suggests, JSONRPC is a
generic @code{Remote Procedure Call} protocol designed around
@acronym{JSON} objects, which you can convert to and from Lisp objects
(@pxref{Parsing JSON}).
@node JSONRPC Overview
@subsection 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,
@pxref{Top,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:
@enumerate
@item A user interface for building JSONRPC applications
In this scenario, the JSONRPC application instantiates
@code{jsonrpc-connection} 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
@code{jsonrpc-notify'}, @code{jsonrpc-request} and
@code{jsonrpc-async-request}. For handling remotely initiated
contacts, which generally come in asynchronously, the instantiation
should include @code{:request-dispatcher} and
@code{: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
@code{jsonrpc-error}, 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
@code{debug-on-error}, in which case this should land you in the
debugger, @pxref{Error Debugging}).
@item 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
@code{jsonrpc-connection-send} 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
@code{jsonrpc-connection-receive} 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.
@end enumerate
@node Process-based JSONRPC connections
@subsection Process-based JSONRPC connections
For convenience, the @code{jsonrpc} library comes built-in with a
@code{jsonrpc-process-connection} 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
@uref{https://microsoft.github.io/language-server-protocol/specification,
Language Server Protocol}.
Along with the mandatory @code{:request-dispatcher} and
@code{:notification-dispatcher} initargs, users of the
@code{jsonrpc-process-connection} class should pass the following
initargs as keyword-value pairs to @code{make-instance}:
@table @code
@item :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.
@item :on-shutdown
Value must be a function of a single argument, the
@code{jsonrpc-process-connection} 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).
@end table
@node JSONRPC JSON object format
@subsection 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
@code{jsonrpc-notify}, @code{jsonrpc-request} and
@code{jsonrpc-async-request}.
To facilitate handling plists, this library make liberal use of
@code{cl-lib} 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:
@example
(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)))
@end example
@node JSONRPC deferred requests
@subsection 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
@code{jsonrpc-async-request} 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
@emph{will} 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
@code{jsonrpc-connection-ready-p} 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
@code{nil} 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

9
etc/NEWS
View file

@ -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

649
lisp/jsonrpc.el Normal file
View file

@ -0,0 +1,649 @@
;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t; -*-
;; Copyright (C) 2018 Free Software Foundation, Inc.
;; Author: João Távora <joaotavora@gmail.com>
;; Maintainer: João Távora <joaotavora@gmail.com>
;; 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

240
test/lisp/jsonrpc-tests.el Normal file
View file

@ -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 <joaotavora@gmail.com>
;; Maintainer: João Távora <joaotavora@gmail.com>
;; 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