[Top][All Lists]

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

feature/jsonrpc-support-dap a56c830b1a6 3/4: Jsonrpc: support some JSONe

From: João Távora
Subject: feature/jsonrpc-support-dap a56c830b1a6 3/4: Jsonrpc: support some JSONesque non-JSONRPC protocols, like DAP
Date: Sun, 10 Dec 2023 21:09:34 -0500 (EST)

branch: feature/jsonrpc-support-dap
commit a56c830b1a661b5aeec911149f721fb9da32fb63
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>

    Jsonrpc: support some JSONesque non-JSONRPC protocols, like DAP
    * lisp/jsonrpc.el (jsonrpc-convert-to-endpoint)
    (jsonrpc-convert-from-endpoint): New generics.
    (jsonrpc-connection-send): Call jsonrpc-convert-to-endpoint.
    Rework logging.
    (jsonrpc-connection-receive): Call jsonrpc-convert-from-endpoint.
    Rework logging. jsonrpc--reply with METHOD.
    (jsonrpc--log-event): Take subtype.
    * test/lisp/progmodes/eglot-tests.el (eglot--sniffing): Adapt
    to new protocol of jsonrpc--log-event.
 lisp/jsonrpc.el                    | 66 +++++++++++++++++++++++---------------
 test/lisp/progmodes/eglot-tests.el | 12 +++----
 2 files changed, 46 insertions(+), 32 deletions(-)

diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
index f658522b487..0009e7b5ef9 100644
--- a/lisp/jsonrpc.el
+++ b/lisp/jsonrpc.el
@@ -133,6 +133,18 @@ immediately."
   (:method (_s _what)   ;; by default all connections are ready
+;;; API optional
+(cl-defgeneric jsonrpc-convert-to-endpoint (connection message method)
+  "Convert JSONRPC message to a JSONRPCesque message accepted by endpoint.
+METHOD duplicates MESSAGE's `:method' property for requests and
+notifications.  Return a plist."
+  (:method (_s message _method) `(:jsonrpc "2.0" ,@message)))
+;;; API optional
+(cl-defgeneric jsonrpc-convert-from-endpoint (connection remote-message)
+  "Convert JSONRPC-esque REMOTE-MESSAGE to a JSONRPC message plist."
+  (:method (_s remote-message) remote-message))
 ;;; Convenience
@@ -170,9 +182,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)
        (;; A remote request
@@ -193,7 +208,7 @@ dispatcher in CONNECTION."
                                         "Internal error")))))
                    '(:error (:code -32603 :message "Internal error"))))))
-          (apply #'jsonrpc--reply connection id reply)))
+          (apply #'jsonrpc--reply connection id method reply)))
        (;; A remote notification
         (funcall (jsonrpc--notification-dispatcher connection)
@@ -435,11 +450,11 @@ connection object, called when the process dies.")
 (cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
                                        &rest args
-                                       _id
+                                       id
-                                       _result
-                                       _error
+                                       (_result nil result-supplied-p)
+                                       error
   "Send MESSAGE, a JSON object, to CONNECTION."
   (when method
@@ -448,18 +463,21 @@ connection object, called when the process dies.")
                      ((symbolp method) (symbol-name method))
                      ((stringp method) method)
                      (t (error "[jsonrpc] invalid method %s" 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")
-             )))
+  (let* ((converted (jsonrpc-convert-to-endpoint connection args method))
+         (json (jsonrpc--json-encode converted))
+         (headers
+          `(("Content-Length" . ,(format "%d" (string-bytes json)))
+            ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8")
+            )))
      (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
+                        (cond ((or result-supplied-p error) 'reply)
+                              (id                    'request)
+                              (method                'notification)))))
 (defun jsonrpc-process-type (conn)
   "Return the `process-type' of JSONRPC connection CONN."
@@ -526,12 +544,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 
+    (connection id method &key (result nil result-supplied-p) (error nil 
   "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."
@@ -741,24 +760,19 @@ TIMEOUT is nil)."
                      (apply #'format format args)
-(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
+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) 
           (let* ((inhibit-read-only t)
-                 (subtype (cond ((and method id)       'request)
-                                (method                'notification)
-                                (id                    'reply)
-                                (t                     'message)))
-                  (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))
                 (let ((msg (format "[%s]%s%s %s:\n%s"
diff --git a/test/lisp/progmodes/eglot-tests.el 
index 575a6ac8ef1..507c6b4fea5 100644
--- a/test/lisp/progmodes/eglot-tests.el
+++ b/test/lisp/progmodes/eglot-tests.el
@@ -209,21 +209,21 @@ directory hierarchy."
             #'jsonrpc--log-event :before
-            (lambda (_proc message &optional type)
+            (lambda (_proc message &optional origin subtype)
               (cl-destructuring-bind (&key method id _error &allow-other-keys)
-                (let ((req-p (and method id))
-                      (notif-p method)
-                      (reply-p id))
+                (let ((req-p (eq subtype 'request))
+                      (notif-p (eq subtype 'notification))
+                      (reply-p (eql subtype 'reply)))
-                   ((eq type 'server)
+                   ((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 type 'client)
+                   ((eq origin 'client)
                     (cond (req-p ,(when client-requests
                                     `(push message ,client-requests)))
                           (notif-p ,(when client-notifications

reply via email to

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