diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index b17eb087f42..e35d449ca6d 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -5919,74 +5919,109 @@ Nevertheless, we can define two distinct APIs around the @cindex JSONRPC application interfaces @enumerate -@item A user interface for building JSONRPC applications +@item An API for building JSONRPC applications @findex :request-dispatcher @findex :notification-dispatcher @findex jsonrpc-notify @findex jsonrpc-request @findex jsonrpc-async-request -In this scenario, the JSONRPC application selects a concrete subclass -of @code{jsonrpc-connection}, and proceeds to create objects of that -subclass 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/or -@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 @code{params} object. +In this scenario, a new aspiring JSONRPC-based application selects a +concrete subclass of @code{jsonrpc-connection} that provides the +transport for the JSONRPC messages to be exchanged between endpoints. + +The application creates objects of that subclass using +@code{make-instance}. To initiate a contact to a remote endpoint, the +application passes this object to the functions such as +@code{jsonrpc-notify}, @code{jsonrpc-request}, or +@code{jsonrpc-async-request}. + +For handling remotely initiated contacts, which generally come in +asynchronously, the @code{make-instance} instantiation should +initialize it the @code{:request-dispatcher} and +@code{:notification-dispatcher} EIEIO keyword arguments. These are +both functions of 3 arguments: the connection object; a symbol naming +the JSONRPC method invoked remotely; and a JSONRPC @code{params} +object. @findex jsonrpc-error 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 (a normal return) or -non-locally (an error return). A local return value must be a Lisp -object that can be serialized as JSON (@pxref{Parsing JSON}). This -determines a success response, and the object is forwarded to the -server as the JSONRPC @code{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 @code{error} are filled out with whatever was passed to +local endpoint (in this case, the application you're building). +Inside that function, you may either return locally (a regular return) +or non-locally (throw an error). Both exits from the request +dispatcher cause a reply to the remote endpoint's request to be sent +through the transport. + +A regular return determines a success response, and the return value +must be a Lisp object that can be serialized as JSON (@pxref{Parsing +JSON}). The result is forwarded to the server as the JSONRPC +@code{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 @code{error} +object 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 calls the Lisp debugger, @pxref{Error Debugging}). -@item A inheritance interface for building JSONRPC transport implementations +@findex jsonrpc-convert-to-endpoint +@findex jsonrpc-convert-from-endpoint +It's possible to use the @code{jsonrpc} library to build applications +based on transport protocols that can be described as +``quasi-JSONRPC''. These are similar, but not quite identical to +JSONRPC, such as the @uref{https://www.jsonrpc.org/, DAP (Debug +Adapter Protocol)}. These protocols also define request, response and +notification messages but the format is not quite the same as JSONRPC. +The generic functions @code{jsonrpc-convert-to-endpoint} and +@code{jsonrpc-convert-from-endpoint} can be customized for converting +between the internal representation of JSONRPC and whatever the +endpoint accepts (@pxref{Generic Functions}). -In this scenario, @code{jsonrpc-connection} is subclassed to implement +@item An API for building JSONRPC transports + +In this scenario, @code{jsonrpc-connection} is sub-classed to implement a different underlying transport strategy (for details on how to subclass, see @ref{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. +to JSONRPC endpoints using that strategy. See @ref{Process-based +JSONRPC connections} for a built-in transport implementation. This API has mandatory and optional parts. @findex jsonrpc-connection-send To allow its users to initiate JSONRPC contacts (notifications or -requests) or reply to endpoint requests, the subclass must have an -implementation of the @code{jsonrpc-connection-send} method. +requests) or reply to endpoint requests, the new transport +implementation must equip the @code{jsonrpc-connection-send} generic +function with a specialization for the the new subclass +(@pxref{Generic Functions}). This generic function is called +automatically by primitives such as @code{jsonrpc-request} and +@code{jsonrpc-notify}. The specialization should ensure that the +message described in the argument list is sent through whatever +underlying communication mechanism (a.k.a.@: ``wire'') is used by the +new transport to talk to endpoints. This ``wire'' may be a network +socket, a serial interface, an HTTP connection, etc. @findex jsonrpc-connection-receive 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). +@code{jsonrpc-connection-receive} to be called from Elisp after +noticing some data on the ``wire'' that can be used to craft a JSONRPC +(or quasi-JSONRPC) message. @findex jsonrpc-shutdown @findex jsonrpc-running-p Finally, and optionally, the @code{jsonrpc-connection} subclass should -implement the @code{jsonrpc-shutdown} and @code{jsonrpc-running-p} -methods if these concepts apply to the transport. If they do, then -any system resources (e.g.@: processes, timers, etc.) used to 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-@code{nil}. +add specializations to the @code{jsonrpc-shutdown} and +@code{jsonrpc-running-p} generic functions if these concepts apply to +the transport. The specialization of @code{jsonrpc-shutdown} should +ensure the release of any system resources (e.g.@: processes, timers, +etc.) used to listen for messages on the wire. The specialization of +@code{jsonrpc-running-p} should tell if these resources are still +active or have already been released (via @code{jsonrpc-shutdown} or +otherwise). @end enumerate diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 7726712d056..dde1c880912 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora ;; Keywords: processes, languages, extensions -;; Version: 1.0.18 +;; Version: 1.0.19 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -51,6 +51,7 @@ (defclass jsonrpc-connection () ((name :accessor jsonrpc-name + :initform "anonymous" :initarg :name :documentation "A name for the connection") (-request-dispatcher @@ -76,6 +77,7 @@ :accessor jsonrpc--events-buffer :documentation "A buffer pretty-printing the JSONRPC events") (-events-buffer-scrollback-size + :initform nil :initarg :events-buffer-scrollback-size :accessor jsonrpc--events-buffer-scrollback-size :documentation "Max size of events buffer. 0 disables, nil means infinite.") @@ -131,6 +133,38 @@ immediately." (:method (_s _what) ;; by default all connections are ready t)) +;;; API optional +(cl-defgeneric jsonrpc-convert-to-endpoint (connection message subtype) + "Convert MESSAGE to JSONRPCesque message accepted by endpoint. +MESSAGE is a plist, jsonrpc.el's internal representation of a +JSONRPC message. SUBTYPE is one of `request', `reply' or +`notification'. + +Return a plist to be serialized to JSON with `json-serialize' and +transmitted to endpoint." + ;; TODO: describe representations and serialization in manual and + ;; link here. + (:method (_s message subtype) + `(:jsonrpc "2.0" + ,@(if (eq subtype 'reply) + ;; true JSONRPC doesn't have `method' + ;; fields in responses. + (cl-loop for (k v) on message by #'cddr + unless (eq k :method) + collect k and collect v) + message)))) + +;;; API optional +(cl-defgeneric jsonrpc-convert-from-endpoint (connection remote-message) + "Convert JSONRPC-esque REMOTE-MESSAGE to a plist. +REMOTE-MESSAGE is a plist read with `json-parse'. + +Return a plist of jsonrpc.el's internal representation of a +JSONRPC message." + ;; TODO: describe representations and serialization in manual and + ;; link here. + (:method (_s remote-message) remote-message)) + ;;; Convenience ;;; @@ -168,9 +202,12 @@ circumvent that.") This function will destructure MESSAGE and call the appropriate dispatcher in CONNECTION." (cl-destructuring-bind (&key method id error params result _jsonrpc) - message + (jsonrpc-convert-from-endpoint connection message) + (jsonrpc--log-event connection message 'server + (cond ((and method id) 'request) + (method 'notification) + (id 'reply))) (let (continuations) - (jsonrpc--log-event connection message 'server) (setf (jsonrpc-last-error connection) error) (cond (;; A remote request @@ -191,7 +228,7 @@ dispatcher in CONNECTION." "Internal error"))))) (error '(:error (:code -32603 :message "Internal error")))))) - (apply #'jsonrpc--reply connection id reply))) + (apply #'jsonrpc--reply connection id method reply))) (;; A remote notification method (funcall (jsonrpc--notification-dispatcher connection) @@ -433,29 +470,34 @@ connection object, called when the process dies.") (cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection) &rest args &key - _id + id method _params - _result - _error + (_result nil result-supplied-p) + 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") - ))) + ((symbolp method) (symbol-name method)) + ((stringp method) method) + (t (error "[jsonrpc] invalid method %s" method))))) + (let* ((subtype (cond ((or result-supplied-p error) 'reply) + (id 'request) + (method 'notification))) + (converted (jsonrpc-convert-to-endpoint connection args subtype)) + (json (jsonrpc--json-encode converted)) + (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))) + (jsonrpc--log-event connection converted 'client subtype))) (defun jsonrpc-process-type (conn) "Return the `process-type' of JSONRPC connection CONN." @@ -522,12 +564,13 @@ With optional CLEANUP, kill any associated buffers." "Encode OBJECT into a JSON string.") (cl-defun jsonrpc--reply - (connection id &key (result nil result-supplied-p) (error nil error-supplied-p)) + (connection id method &key (result nil result-supplied-p) (error nil error-supplied-p)) "Reply to CONNECTION's request ID with RESULT or ERROR." (apply #'jsonrpc-connection-send connection `(:id ,id ,@(and result-supplied-p `(:result ,result)) - ,@(and error-supplied-p `(:error ,error))))) + ,@(and error-supplied-p `(:error ,error)) + :method ,method))) (defun jsonrpc--call-deferred (connection) "Call CONNECTION's deferred actions, who may again defer themselves." @@ -560,27 +603,12 @@ With optional CLEANUP, kill any associated buffers." (delete-process proc) (funcall (jsonrpc--on-shutdown connection) connection))))) -(defvar jsonrpc--in-process-filter nil - "Non-nil if inside `jsonrpc--process-filter'.") - (cl-defun jsonrpc--process-filter (proc string) "Called when new data STRING has arrived for PROC." - (when jsonrpc--in-process-filter - ;; Problematic recursive process filters may happen if - ;; `jsonrpc--connection-receive', called by us, eventually calls - ;; client code which calls `process-send-string' (which see) to, - ;; say send a follow-up message. If that happens to writes enough - ;; bytes for pending output to be received, we will lose JSONRPC - ;; messages. In that case, remove recursiveness by re-scheduling - ;; ourselves to run from within a timer as soon as possible - ;; (bug#60088) - (run-at-time 0 nil #'jsonrpc--process-filter proc string) - (cl-return-from jsonrpc--process-filter)) (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) - (let* ((jsonrpc--in-process-filter t) - (connection (process-get proc 'jsonrpc-connection)) - (expected-bytes (jsonrpc--expected-bytes connection))) + (let* ((conn (process-get proc 'jsonrpc-connection)) + (expected-bytes (jsonrpc--expected-bytes conn))) ;; Insert the text, advancing the process marker. ;; (save-excursion @@ -615,24 +643,24 @@ With optional CLEANUP, kill any associated buffers." expected-bytes) (let* ((message-end (byte-to-position (+ (position-bytes (point)) - expected-bytes)))) + expected-bytes))) + message + ) (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))))) + (setq message + (condition-case-unless-debug oops + (jsonrpc--json-read) + (error + (jsonrpc--warn "Invalid JSON: %s %s" + (cdr oops) (buffer-string)) + nil))) + (when message + (process-put proc 'jsonrpc-mqueue + (nconc (process-get proc + 'jsonrpc-mqueue) + (list message))))) (goto-char message-end) (let ((inhibit-read-only t)) (delete-region (point-min) (point))) @@ -641,9 +669,21 @@ With optional CLEANUP, kill any associated buffers." ;; Message is still incomplete ;; (setq done :waiting-for-more-bytes-in-this-message)))))))) - ;; Saved parsing state for next visit to this filter + ;; Saved parsing state for next visit to this filter, which + ;; may well be a recursive one stemming from the tail call + ;; to `jsonrpc-connection-receive' below (bug#60088). ;; - (setf (jsonrpc--expected-bytes connection) expected-bytes)))))) + (setf (jsonrpc--expected-bytes conn) expected-bytes) + ;; Now, time to notify user code of one or more messages in + ;; order. Very often `jsonrpc-connection-receive' will exit + ;; non-locally (typically the reply to a request), so do + ;; this all this processing in top-level loops timer. + (cl-loop + for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg + do (run-at-time 0 nil + (lambda (m) (with-temp-buffer + (jsonrpc-connection-receive conn m))) + msg))))))) (cl-defun jsonrpc--async-request-1 (connection method @@ -737,24 +777,19 @@ TIMEOUT is nil)." (apply #'format format args) :warning))) -(defun jsonrpc--log-event (connection message &optional type) +(defun jsonrpc--log-event (connection message &optional origin subtype) "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." +plist. ORIGIN is a symbol saying where event originated. +SUBTYPE tells more about the event." (let ((max (jsonrpc--events-buffer-scrollback-size connection))) (when (or (null max) (cl-plusp max)) (with-current-buffer (jsonrpc-events-buffer connection) - (cl-destructuring-bind (&key method id error &allow-other-keys) message + (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))))) + (concat (format "%s" (or origin 'internal)) + (if origin (format "-%s" (or subtype 'message)))))) (goto-char (point-max)) (prog1 (let ((msg (format "[%s]%s%s %s:\n%s" diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el index 85ac96a931c..5c3b694194f 100644 --- a/test/lisp/jsonrpc-tests.el +++ b/test/lisp/jsonrpc-tests.el @@ -103,6 +103,7 @@ (process-get listen-server 'handlers)))))))) (cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body) + (declare (indent 1)) `(jsonrpc--call-with-emacsrpc-fixture (lambda (,endpoint-sym) ,@body))) (ert-deftest returns-3 () @@ -151,14 +152,6 @@ [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) diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 575a6ac8ef1..996ff276e68 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -209,27 +209,25 @@ directory hierarchy." client-replies)) (advice-add #'jsonrpc--log-event :before - (lambda (_proc message &optional type) - (cl-destructuring-bind (&key method id _error &allow-other-keys) - message - (let ((req-p (and method id)) - (notif-p method) - (reply-p id)) - (cond - ((eq type 'server) - (cond (req-p ,(when server-requests - `(push message ,server-requests))) - (notif-p ,(when server-notifications - `(push message ,server-notifications))) - (reply-p ,(when server-replies - `(push message ,server-replies))))) - ((eq type 'client) - (cond (req-p ,(when client-requests - `(push message ,client-requests))) - (notif-p ,(when client-notifications - `(push message ,client-notifications))) - (reply-p ,(when client-replies - `(push message ,client-replies))))))))) + (lambda (_proc message &optional origin subtype) + (let ((req-p (eq subtype 'request)) + (notif-p (eq subtype 'notification)) + (reply-p (eql subtype 'reply))) + (cond + ((eq origin 'server) + (cond (req-p ,(when server-requests + `(push message ,server-requests))) + (notif-p ,(when server-notifications + `(push message ,server-notifications))) + (reply-p ,(when server-replies + `(push message ,server-replies))))) + ((eq origin 'client) + (cond (req-p ,(when client-requests + `(push message ,client-requests))) + (notif-p ,(when client-notifications + `(push message ,client-notifications))) + (reply-p ,(when client-replies + `(push message ,client-replies)))))))) '((name . ,log-event-ad-sym))) ,@body) (advice-remove #'jsonrpc--log-event ',log-event-ad-sym))))