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

Merge remote-tracking branch 'savannah/master' into master-android-1

Browse source
This commit is contained in:
Po Lu 2023-12-14 13:25:40 +08:00
commit f5a3b5e66a
4 changed files with 186 additions and 125 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

103
doc/lispref/text.texi
View file

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

159
lisp/jsonrpc.el
View file

@ -4,7 +4,7 @@
;; Author: João Távora <joaotavora@gmail.com>
;; 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"

9
test/lisp/jsonrpc-tests.el
View file

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

40
test/lisp/progmodes/eglot-tests.el
View file

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