emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

master f5a3b5e66a8 2/2: Merge remote-tracking branch 'savannah/master' i


From: Po Lu
Subject: master f5a3b5e66a8 2/2: Merge remote-tracking branch 'savannah/master' into master-android-1
Date: Thu, 14 Dec 2023 00:25:54 -0500 (EST)

branch: master
commit f5a3b5e66a8fd5d397a4540bde6826ef56c5b8eb
Merge: de25aaa11a8 ea29a48da13
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>

    Merge remote-tracking branch 'savannah/master' into master-android-1
---
 doc/lispref/text.texi              | 105 ++++++++++++++++--------
 lisp/jsonrpc.el                    | 159 ++++++++++++++++++++++---------------
 test/lisp/jsonrpc-tests.el         |   9 +--
 test/lisp/progmodes/eglot-tests.el |  40 +++++-----
 4 files changed, 187 insertions(+), 126 deletions(-)

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
-
-In this scenario, @code{jsonrpc-connection} is subclassed to implement
+@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}).
+
+@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 <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"
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))))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]