[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
t))
+;;; 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)
(cond
(;; A remote request
@@ -193,7 +208,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)
@@ -435,11 +450,11 @@ 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
@@ -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")
+ )))
(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
+ (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
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."
@@ -741,24 +760,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/progmodes/eglot-tests.el
b/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."
client-replies))
(advice-add
#'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)
message
- (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)))
(cond
- ((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