branch: externals/eglot
commit 4525eca32a10046484b5a6dd1f0647927aae2dd6
Author: João Távora <joaotav...@gmail.com>
Commit: João Távora <joaotav...@gmail.com>
Support json.c. API purely based on classes
No more jsonrpc-connect.
This is a big commit because of a data loss problem. It should be at
least two separate commits (json.c-support and new API)
* eglot.el (eglot-server-programs): Rework docstring.
(eglot-handle-request): Don't take ID param
(eglot-lsp-server): No more initargs.
(eglot--interactive): Return 5 args.
(eglot): Take 5 args.
(eglot-reconnect): Pass 6 args to eglot--connect.
(eglot--dispatch): Remove.
(eglot--connect): Take 6 args. Rework.
(eglot-handle-notification): Change all specializations
to use a non-keyword symbol spec.
(eglot-handle-request): Remove ID param from all
specializations. Don't pass ID to jsonrpc-reply.
(eglot--register-unregister): Don't take JSONRPC-ID arg.
Don't pass ID to jsonrpc-reply.
* jsonrpc-tests.el (returns-3, signals-an--32603-JSONRPC-error)
(times-out, stretching-it-but-works)
(json-el-cant-serialize-this, jsonrpc-connection-ready-p)
(deferred-action-intime, deferred-action-toolate)
(deferred-action-timeout): Pass JSON objects compatible with
json.c
(jsonrpc--test-client, jsonrpc--test-endpoint): New classes
(jsonrpc--with-emacsrpc-fixture): Don't use jsonrpc-connect.
(jsonrpc-connection-ready-p): Update signature.
* jsonrpc.el: Rewrite commentary.
(jsonrpc-connection): Rework class.
(jsonrpc-process-connection): Rework class.
(initialize-instance): New methods..
(jsonrpc--json-read, jsonrpc--json-encode): Reindent.
(jsonrpc-connect): Delete.
(jsonrpc--json-read, jsonrpc--json-encode):
New functions for working with json.c
(jsonrpc--process-filter): Call them.
(jsonrpc--unanswered-request-id): New variable.
(jsonrpc--connection-receive): Use jsonrpc--unanswered-request-id
(jsonrpc-connection-send): Take keyword params to build message
instead of message.
(jsonrpc-notify, jsonrpc--async-request-1): Use new
jsonrpc-connection-send.
(jsonrpc-reply): Simplify.
* eglot-tests.el (rls-watches-files, rls-basic-diagnostics)
(rls-hover-after-edit): Correctly compare using string= and
non-keyword symbols.
---
eglot-tests.el | 8 +-
eglot.el | 171 ++++++++++++----------
jsonrpc-tests.el | 65 +++++----
jsonrpc.el | 429 ++++++++++++++++++++++++-------------------------------
4 files changed, 324 insertions(+), 349 deletions(-)
diff --git a/eglot-tests.el b/eglot-tests.el
index af8cc37..bd9e2f3 100644
--- a/eglot-tests.el
+++ b/eglot-tests.el
@@ -250,7 +250,7 @@ Pass TIMEOUT to `eglot--with-timeout'."
(eglot--wait-for (s-requests 1)
(&key id method &allow-other-keys)
(setq register-id id)
- (string= method "client/registerCapability"))
+ (string= method 'client/registerCapability))
(eglot--wait-for (c-replies 1)
(&key id error &allow-other-keys)
(and (eq id register-id) (null error))))
@@ -258,7 +258,7 @@ Pass TIMEOUT to `eglot--with-timeout'."
(eglot--wait-for
(c-notifs 3 "waiting for didChangeWatchedFiles notification")
(&key method params &allow-other-keys)
- (and (eq method :workspace/didChangeWatchedFiles)
+ (and (string= method 'workspace/didChangeWatchedFiles)
(cl-destructuring-bind (&key uri type)
(elt (plist-get params :changes) 0)
(and (string= (eglot--path-to-uri "Cargo.toml") uri)
@@ -278,7 +278,7 @@ Pass TIMEOUT to `eglot--with-timeout'."
(apply #'eglot (eglot--interactive))
(eglot--wait-for (s-notifs 1)
(&key _id method &allow-other-keys)
- (string= method "textDocument/publishDiagnostics"))
+ (string= method 'textDocument/publishDiagnostics))
(flymake-start)
(goto-char (point-min))
(flymake-goto-next-error 1 '() t)
@@ -318,7 +318,7 @@ Pass TIMEOUT to `eglot--with-timeout'."
(eglot--wait-for (c-reqs)
(&key id method &allow-other-keys)
(setq pending-id id)
- (string= method :textDocument/documentHighlight))
+ (string= method 'textDocument/documentHighlight))
(eglot--wait-for (s-replies)
(&key id &allow-other-keys)
(eq id pending-id))))))))
diff --git a/eglot.el b/eglot.el
index d5498f9..e1592ab 100644
--- a/eglot.el
+++ b/eglot.el
@@ -79,8 +79,8 @@
(php-mode . ("php" "vendor/felixfbecker/\
language-server/bin/php-language-server.php")))
"How the command `eglot' guesses the server to start.
-An association list of (MAJOR-MODE . SPEC) pair. MAJOR-MODE is a
-mode symbol. SPEC is
+An association list of (MAJOR-MODE . CONTACT) pair. MAJOR-MODE
+is a mode symbol. CONTACT is:
* In the most common case, a list of strings (PROGRAM [ARGS...]).
PROGRAM is called with ARGS and is expected to serve LSP requests
@@ -91,12 +91,15 @@ a positive integer number for connecting to a server via
TCP.
Remaining ARGS are passed to `open-network-stream' for upgrading
the connection with encryption or other capabilities.
-* A function of no arguments returning a connected process.
-
-* A cons (CLASS-NAME . SPEC) where CLASS-NAME is a symbol
-designating a subclass of symbol `eglot-lsp-server', for
-representing experimental LSP servers. In this case SPEC is
-interpreted as described above this point.")
+* A cons (CLASS-NAME . INITARGS) where CLASS-NAME is a symbol
+designating a subclass of `eglot-lsp-server', for representing
+experimental LSP servers. INITARGS is a keyword-value plist used
+to initialize CLASS-NAME, or a plain list interpreted as the
+previous descriptions of CONTACT, in which case it is converted
+to produce a plist with a suitable :PROCESS initarg to
+CLASS-NAME. The class `eglot-lsp-server' descends
+`jsonrpc-process-connection', which you should see for semantics
+of the mandatory :PROCESS argument.")
(defface eglot-mode-line
'((t (:inherit font-lock-constant-face :weight bold)))
@@ -124,8 +127,8 @@ lasted more than that many seconds."
"Save excursion and restriction. Widen. Then run BODY." (declare (debug t))
`(save-excursion (save-restriction (widen) ,@body)))
-(cl-defgeneric eglot-handle-request (server method id &rest params)
- "Handle SERVER's METHOD request with ID and PARAMS.")
+(cl-defgeneric eglot-handle-request (server method &rest params)
+ "Handle SERVER's METHOD request with PARAMS.")
(cl-defgeneric eglot-handle-notification (server method id &rest params)
"Handle SERVER's METHOD notification with PARAMS.")
@@ -164,10 +167,10 @@ lasted more than that many seconds."
(defclass eglot-lsp-server (jsonrpc-process-connection)
((project-nickname
:documentation "Short nickname for the associated project."
- :initarg :project-nickname :accessor eglot--project-nickname)
+ :accessor eglot--project-nickname)
(major-mode
:documentation "Major mode symbol."
- :initarg :major-mode :accessor eglot--major-mode)
+ :accessor eglot--major-mode)
(capabilities
:documentation "JSON object containing server capabilities."
:accessor eglot--capabilities)
@@ -176,19 +179,22 @@ lasted more than that many seconds."
:accessor eglot--shutdown-requested)
(project
:documentation "Project associated with server."
- :initarg :project :accessor eglot--project)
+ :accessor eglot--project)
(spinner
:documentation "List (ID DOING-WHAT DONE-P) representing server progress."
:initform `(nil nil t) :accessor eglot--spinner)
(inhibit-autoreconnect
:documentation "Generalized boolean inhibiting auto-reconnection if true."
- :initarg :inhibit-autoreconnect :accessor eglot--inhibit-autoreconnect)
+ :accessor eglot--inhibit-autoreconnect)
(file-watches
:documentation "Map ID to list of WATCHES for `didChangeWatchedFiles'."
:initform (make-hash-table :test #'equal) :accessor eglot--file-watches)
(managed-buffers
:documentation "List of buffers managed by server."
- :initarg :managed-buffers :accessor eglot--managed-buffers))
+ :accessor eglot--managed-buffers)
+ (saved-initargs
+ :documentation "Saved initargs for reconnection purposes"
+ :accessor eglot--saved-initargs))
:documentation
"Represents a server. Wraps a process for LSP communication.")
@@ -296,47 +302,35 @@ function with the server still running."
(list (match-string 1 s) (string-to-number (match-string 2
s)))
(split-string-and-unquote s)))
guess)))
- (list managed-mode project (cons class contact) t)))
+ (list managed-mode project class contact t)))
;;;###autoload
-(defun eglot (managed-major-mode project contact &optional interactive)
+(defun eglot (managed-major-mode project class contact &optional interactive)
"Manage a project with a Language Server Protocol (LSP) server.
-The LSP server is started (or contacted) via CONTACT. If this
-operation is successful, current *and future* file buffers of
-MANAGED-MAJOR-MODE inside PROJECT automatically become
+The LSP server of CLASS started (or contacted) via CONTACT. If
+this operation is successful, current *and future* file buffers
+of MANAGED-MAJOR-MODE inside PROJECT automatically become
\"managed\" by the LSP server, meaning information about their
contents is exchanged periodically to provide enhanced
code-analysis via `xref-find-definitions', `flymake-mode',
`eldoc-mode', `completion-at-point', among others.
Interactively, the command attempts to guess MANAGED-MAJOR-MODE
-from current buffer, CONTACT from `eglot-server-programs' and
-PROJECT from `project-current'. If it can't guess, the user is
-prompted. With a single \\[universal-argument] prefix arg, it
-always prompt for COMMAND. With two \\[universal-argument]
-prefix args, also prompts for MANAGED-MAJOR-MODE.
+from current buffer, CLASS and CONTACT from
+`eglot-server-programs' and PROJECT from `project-current'. If
+it can't guess, the user is prompted. With a single
+\\[universal-argument] prefix arg, it always prompt for COMMAND.
+With two \\[universal-argument] prefix args, also prompts for
+MANAGED-MAJOR-MODE.
PROJECT is a project instance as returned by `project-current'.
-CONTACT specifies how to contact the server. It can be:
-
-* a list of strings (COMMAND [ARGS...]) specifying how
-to start a server subprocess to connect to.
-
-* A list with a string as the first element and an integer number
-as the second list is interpreted as (HOST PORT [PARAMETERS...])
-and connects to an existing server via TCP, with the remaining
-PARAMETERS being given as `open-network-stream's optional
-arguments.
+CLASS is a subclass of symbol `eglot-lsp-server'.
-* A list (CLASS-SYM CONTACT...) where CLASS-SYM names the
-subclass of `eglot-server' used to create the server object. The
-remaining arguments are processed as described in the previous
-paragraphs.
-
-* A function of arguments returning arguments compatible with the
-previous description.
+CONTACT specifies how to contact the server. It is a
+keyword-value plist used to initialize CLASS or a plain list as
+described in `eglot-server-programs', which see.
INTERACTIVE is t if called interactively."
(interactive (eglot--interactive))
@@ -354,6 +348,7 @@ INTERACTIVE is t if called interactively."
managed-major-mode
(format "%s/%s" nickname
managed-major-mode)
nickname
+ class
contact)))
(eglot--message "Connected! Process `%s' now \
managing `%s' buffers in project `%s'."
@@ -371,29 +366,51 @@ INTERACTIVE is t if called interactively."
(eglot--major-mode server)
(jsonrpc-name server)
(eglot--project-nickname server)
- (jsonrpc-contact server))
+ (eieio-object-class-name server)
+ (eglot--saved-initargs server))
(eglot--message "Reconnected!"))
(defalias 'eglot-events-buffer 'jsonrpc-events-buffer)
(defvar eglot-connect-hook nil "Hook run after connecting in
`eglot--connect'.")
-(defun eglot--dispatch (server method id params)
- "Dispatcher passed to `jsonrpc-connect'.
-Calls a function on SERVER, METHOD ID and PARAMS."
- (let ((method (intern (format ":%s" method))))
- (if id
- (apply #'eglot-handle-request server id method params)
- (apply #'eglot-handle-notification server method params)
- (force-mode-line-update t))))
-
-(defun eglot--connect (project managed-major-mode name nickname contact)
+(defun eglot--connect (project managed-major-mode name nickname
+ class contact)
"Connect to PROJECT, MANAGED-MAJOR-MODE, NAME.
-And NICKNAME and CONTACT."
- (let* ((contact (if (functionp contact) (funcall contact) contact))
+And don't forget NICKNAME and CLASS, CONTACT. This docstring
+appeases checkdoc, that's all."
+ (let* ((readable-name (format "EGLOT (%s/%s)" nickname managed-major-mode))
+ (initargs
+ (cond ((keywordp (car contact)) contact)
+ ((integerp (cadr contact))
+ `(:process ,(lambda ()
+ (apply #'open-network-stream
+ readable-name nil
+ (car contact) (cadr contact)
+ (cddr contact)))))
+ ((stringp (car contact))
+ `(:process ,(lambda ()
+ (make-process
+ :name readable-name
+ :command contact
+ :connection-type 'pipe
+ :coding 'utf-8-emacs-unix
+ :stderr (get-buffer-create
+ (format "*%s stderr*"
readable-name))))))))
+ (spread
+ (lambda (fn)
+ (lambda (&rest args)
+ (apply fn (append (butlast args) (car (last args)))))))
(server
- (jsonrpc-connect name contact #'eglot--dispatch
#'eglot--on-shutdown))
+ (apply
+ #'make-instance class
+ :name name
+ :notification-dispatcher (funcall spread
#'eglot-handle-notification)
+ :request-dispatcher (funcall spread #'eglot-handle-request)
+ :on-shutdown #'eglot--on-shutdown
+ initargs))
success)
+ (setf (eglot--saved-initargs server) initargs)
(setf (eglot--project server) project)
(setf (eglot--project-nickname server) nickname)
(setf (eglot--major-mode server) managed-major-mode)
@@ -688,14 +705,14 @@ Uses THING, FACE, DEFS and PREPEND."
;;; Protocol implementation (Requests, notifications, etc)
;;;
(cl-defmethod eglot-handle-notification
- (_server (_method (eql :window/showMessage)) &key type message)
+ (_server (_method (eql window/showMessage)) &key type message)
"Handle notification window/showMessage"
(eglot--message (propertize "Server reports (type=%s): %s"
'face (if (<= type 1) 'error))
type message))
(cl-defmethod eglot-handle-request
- (server id (_method (eql :window/showMessageRequest)) &key type message
actions)
+ (server (_method (eql window/showMessageRequest)) &key type message actions)
"Handle server request window/showMessageRequest"
(let (reply)
(unwind-protect
@@ -710,23 +727,23 @@ Uses THING, FACE, DEFS and PREPEND."
'("OK"))
nil t (plist-get (elt actions 0) :title)))
(if reply
- (jsonrpc-reply server id :result `(:title ,reply))
- (jsonrpc-reply server id
+ (jsonrpc-reply server :result `(:title ,reply))
+ (jsonrpc-reply server
:error `(:code -32800 :message "User cancelled"))))))
(cl-defmethod eglot-handle-notification
- (_server (_method (eql :window/logMessage)) &key _type _message)
+ (_server (_method (eql window/logMessage)) &key _type _message)
"Handle notification window/logMessage") ;; noop, use events buffer
(cl-defmethod eglot-handle-notification
- (_server (_method (eql :telemetry/event)) &rest _any)
+ (_server (_method (eql telemetry/event)) &rest _any)
"Handle notification telemetry/event") ;; noop, use events buffer
(defvar-local eglot--unreported-diagnostics nil
"Unreported diagnostics for this buffer.")
(cl-defmethod eglot-handle-notification
- (server (_method (eql :textDocument/publishDiagnostics)) &key uri
diagnostics)
+ (server (_method (eql textDocument/publishDiagnostics)) &key uri diagnostics)
"Handle notification publishDiagnostics"
(if-let ((buffer (find-buffer-visiting (eglot--uri-to-path uri))))
(with-current-buffer buffer
@@ -750,7 +767,7 @@ Uses THING, FACE, DEFS and PREPEND."
(setq eglot--unreported-diagnostics (cons t diags))))))
(jsonrpc--debug server "Diagnostics received for unvisited %s" uri)))
-(cl-defun eglot--register-unregister (server jsonrpc-id things how)
+(cl-defun eglot--register-unregister (server things how)
"Helper for `registerCapability'.
THINGS are either registrations or unregisterations."
(dolist (thing (cl-coerce things 'list))
@@ -762,28 +779,28 @@ THINGS are either registrations or unregisterations."
(unless (eq t (car retval))
(cl-return-from eglot--register-unregister
(jsonrpc-reply
- server jsonrpc-id
+ server
:error `(:code -32601 :message ,(or (cadr retval)
"sorry")))))))))
- (jsonrpc-reply server jsonrpc-id :result `(:message "OK")))
+ (jsonrpc-reply server :result `(:message "OK")))
(cl-defmethod eglot-handle-request
- (server id (_method (eql :client/registerCapability)) &key registrations)
+ (server (_method (eql client/registerCapability)) &key registrations)
"Handle server request client/registerCapability"
- (eglot--register-unregister server id registrations 'register))
+ (eglot--register-unregister server registrations 'register))
(cl-defmethod eglot-handle-request
- (server id (_method (eql :client/unregisterCapability))
+ (server (_method (eql client/unregisterCapability))
&key unregisterations) ;; XXX: "unregisterations" (sic)
"Handle server request client/unregisterCapability"
- (eglot--register-unregister server id unregisterations 'unregister))
+ (eglot--register-unregister server unregisterations 'unregister))
(cl-defmethod eglot-handle-request
- (server id (_method (eql :workspace/applyEdit)) &key _label edit)
+ (server (_method (eql workspace/applyEdit)) &key _label edit)
"Handle server request workspace/applyEdit"
(condition-case err
(progn (eglot--apply-workspace-edit edit 'confirm)
- (jsonrpc-reply server id :result `(:applied )))
- (error (jsonrpc-reply server id
+ (jsonrpc-reply server :result `(:applied )))
+ (error (jsonrpc-reply server
:result `(:applied :json-false)
:error `(:code -32001 :message (format "%s"
,err))))))
@@ -1348,7 +1365,7 @@ If SKIP-SIGNATURE, don't try to send
textDocument/signatureHelp."
(and (equal "Indexing" what) done)))))
(cl-defmethod eglot-handle-notification
- ((server eglot-rls) (_method (eql :window/progress))
+ ((server eglot-rls) (_method (eql window/progress))
&key id done title message &allow-other-keys)
"Handle notification window/progress"
(setf (eglot--spinner server) (list id title done message)))
@@ -1367,17 +1384,17 @@ If SKIP-SIGNATURE, don't try to send
textDocument/signatureHelp."
:progressReportFrequencyMs -1)))
(cl-defmethod eglot-handle-notification
- ((_server eglot-cquery) (_method (eql :$cquery/progress))
+ ((_server eglot-cquery) (_method (eql $cquery/progress))
&rest counts &key _activeThreads &allow-other-keys)
"No-op for noisy $cquery/progress extension")
(cl-defmethod eglot-handle-notification
- ((_server eglot-cquery) (_method (eql :$cquery/setInactiveRegions))
+ ((_server eglot-cquery) (_method (eql $cquery/setInactiveRegions))
&key _uri _inactiveRegions &allow-other-keys)
"No-op for unsupported $cquery/setInactiveRegions extension")
(cl-defmethod eglot-handle-notification
- ((_server eglot-cquery) (_method (eql :$cquery/publishSemanticHighlighting))
+ ((_server eglot-cquery) (_method (eql $cquery/publishSemanticHighlighting))
&key _uri _symbols &allow-other-keys)
"No-op for unsupported $cquery/publishSemanticHighlighting extension")
diff --git a/jsonrpc-tests.el b/jsonrpc-tests.el
index 33a7ae5..d59f1a0 100644
--- a/jsonrpc-tests.el
+++ b/jsonrpc-tests.el
@@ -30,9 +30,11 @@
(require 'jsonrpc)
(require 'eieio)
-(defclass jsonrpc-test-conn (jsonrpc-process-connection)
- ((hold-deferred :initform t :accessor jsonrpc--hold-deferred)
- (shutdown-complete-p :initform nil :accessor jsonrpc--shutdown-complete-p)))
+(defclass jsonrpc--test-endpoint (jsonrpc-process-connection)
+ ((scp :accessor jsonrpc--shutdown-complete-p)))
+
+(defclass jsonrpc--test-client (jsonrpc--test-endpoint)
+ ((hold-deferred :initform t :accessor jsonrpc--hold-deferred)))
(cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body)
(declare (indent 1) (debug t))
@@ -44,25 +46,30 @@
:service 44444
:log (lambda (_server client _message)
(setq ,server
- (jsonrpc-connect
- (process-name client)
- (make-instance 'jsonrpc-test-conn :process client)
- (lambda (endpoint method id params)
+ (make-instance
+ 'jsonrpc--test-endpoint
+ :name (process-name client)
+ :process client
+ :request-dispatcher
+ (lambda (endpoint method params)
(unless (memq method '(+ - * / vconcat append
sit-for ignore))
(signal 'jsonrpc-error
`((jsonrpc-error-message
. "Sorry, this isn't allowed")
(jsonrpc-error-code . -32601))))
- (jsonrpc-reply endpoint id :result
- (apply method (append params
nil))))
+ (let ((result (apply method (append params
nil))))
+ (jsonrpc-reply endpoint :result result)))
+ :on-shutdown
(lambda (conn)
(setf (jsonrpc--shutdown-complete-p conn)
t)))))))
- (,endpoint-sym (jsonrpc-connect
+ (,endpoint-sym (make-instance
+ 'jsonrpc--test-client
"Emacs RPC client"
- '(jsonrpc-test-conn "localhost" 44444)
- (lambda (_endpoint method _id &rest _params)
- (message "server wants to %s" method))
+ :process
+ (open-network-stream "JSONRPC test tcp endpoint"
+ nil "localhost" 44444)
+ :on-shutdown
(lambda (conn)
(setf (jsonrpc--shutdown-complete-p conn) t)))))
(unwind-protect
@@ -93,7 +100,7 @@
(ert-deftest returns-3 ()
"returns 3"
(jsonrpc--with-emacsrpc-fixture (conn)
- (should (= 3 (jsonrpc-request conn '+ '(1 2))))))
+ (should (= 3 (jsonrpc-request conn '+ [1 2])))))
(ert-deftest errors-with--32601 ()
"errors with -32601"
@@ -110,7 +117,7 @@
(jsonrpc--with-emacsrpc-fixture (conn)
(condition-case err
(progn
- (jsonrpc-request conn '+ '(a 2))
+ (jsonrpc-request conn '+ ["a" 2])
(ert-fail "A `jsonrpc-error' should have been signalled!"))
(jsonrpc-error
(should (= -32603 (cdr (assoc 'jsonrpc-error-code (cdr err)))))))))
@@ -119,23 +126,23 @@
"times out"
(jsonrpc--with-emacsrpc-fixture (conn)
(should-error
- (jsonrpc-request conn 'sit-for '(5) :timeout 2))))
+ (jsonrpc-request conn 'sit-for [5] :timeout 2))))
(ert-deftest stretching-it-but-works ()
"stretching it, but works"
(jsonrpc--with-emacsrpc-fixture (conn)
(should (equal
[1 2 3 3 4 5]
- (jsonrpc-request conn 'vconcat '([1 2 3] [3 4 5]))))))
+ (jsonrpc-request conn 'vconcat [[1 2 3] [3 4 5]])))))
(ert-deftest json-el-cant-serialize-this ()
- "json.el can't serialize this, json.el errors and request isn't sent"
+ "json.el can't serialize the response."
(jsonrpc--with-emacsrpc-fixture (conn)
(should-error
- (jsonrpc-request conn 'append '((1 2 3) (3 4 5))))))
+ (jsonrpc-request conn 'append [[1 2 3] [3 4 5]]))))
(cl-defmethod jsonrpc-connection-ready-p
- ((conn jsonrpc-test-conn) what)
+ ((conn jsonrpc--test-client) what)
(and (cl-call-next-method)
(or (not (string-match "deferred" what))
(not (jsonrpc--hold-deferred conn)))))
@@ -146,14 +153,14 @@
;; success fun which sets the flag only runs after some time.
(jsonrpc--with-emacsrpc-fixture (conn)
(jsonrpc-async-request conn
- 'sit-for '(0.5)
+ 'sit-for [0.5]
:success-fn
(lambda (_result)
(setf (jsonrpc--hold-deferred conn) nil)))
;; Now wait for an answer to this request, which should be sent as
;; soon as the previous one is answered.
(should
- (= 3 (jsonrpc-request conn '+ '(1 2)
+ (= 3 (jsonrpc-request conn '+ [1 2]
:deferred "deferred"
:timeout 1)))))
@@ -165,26 +172,26 @@
(let (n-deferred-1 n-deferred-2)
(jsonrpc-async-request
conn
- 'sit-for '(0.1)
+ 'sit-for [0.1]
:success-fn
(lambda (_result)
(setq n-deferred-1 (hash-table-count (jsonrpc--deferred-actions
conn)))))
(should-error
- (jsonrpc-request conn 'ignore '("first deferred")
+ (jsonrpc-request conn 'ignore ["first deferred"]
:deferred "first deferred"
:timeout 0.5)
:type 'jsonrpc-error)
(jsonrpc-async-request
conn
- 'sit-for '(0.1)
+ 'sit-for [0.1]
:success-fn
(lambda (_result)
(setq n-deferred-2 (hash-table-count (jsonrpc--deferred-actions
conn)))
(setf (jsonrpc--hold-deferred conn) nil)))
- (jsonrpc-async-request conn 'ignore '("second deferred")
+ (jsonrpc-async-request conn 'ignore ["second deferred"]
:deferred "second deferred"
:timeout 1)
- (jsonrpc-request conn 'ignore '("third deferred")
+ (jsonrpc-request conn 'ignore ["third deferred"]
:deferred "third deferred"
:timeout 1)
(should (eq 1 n-deferred-1))
@@ -195,11 +202,11 @@
"Deferred request fails because noone clears the flag."
(jsonrpc--with-emacsrpc-fixture (conn)
(should-error
- (jsonrpc-request conn '+ '(1 2)
+ (jsonrpc-request conn '+ [1 2]
:deferred "deferred-testing" :timeout 0.5)
:type 'jsonrpc-error)
(should
- (= 3 (jsonrpc-request conn '+ '(1 2)
+ (= 3 (jsonrpc-request conn '+ [1 2]
:timeout 0.5)))))
(provide 'jsonrpc-tests)
diff --git a/jsonrpc.el b/jsonrpc.el
index 55d4dba..d3aed36 100644
--- a/jsonrpc.el
+++ b/jsonrpc.el
@@ -34,46 +34,45 @@
;; http, or in many various message passing environments."
;;
;; To approach this agnosticism, jsonrpc.el uses objects derived from
-;; an abstract class, `jsonrpc-connection' to represent the connection
-;; to the remote JSON endpoint. Abstract operations such as sending
-;; and receiving are modelled as generic functions, so that users of
-;; JSONRPC working in complicated transport infrastructures can
+;; a base `jsonrpc-connection' class, which is "abstract" or "virtual"
+;; (in modern OO parlance) and represents the connection to the remote
+;; JSON endpoint. Equally abstract operations such as sending and
+;; receiving are modelled as generic functions, so JSONRPC
+;; applications operating over arbitrary transport infrastructures can
;; specify a subclass of `jsonrpc-connection' and write specific
-;; methods for it. Nevertheless, jsonrpc.el comes built-in with
-;; `jsonrpc-process-connection' class that works both with local
-;; subprocesses (through stdin/stdout) and TCP hosts (using
-;; sockets). This uses some simple HTTP-style envelopping for JSON
-;; objects travelling through the wire.
+;; methods for it.
;;
-;; The entry point `jsonrpc-connect', returns one of these objects by
-;; default. It is passed a name identifying the connection and a
-;; "contact", which will determine the connection type to make. This
-;; contact can a list of strings (a command and arguments for creating
-;; subprocesses) or a list of the form (HOST PORT-NUMBER PARAMS...)
-;; for connecting via TCP. For the providing the aforementioned
-;; flexibility, it can also be a any object of a subclass of
-;; `jsonrpc-connection'.
+;; The `jsonrpc-connection' constructor is the most generic entry
+;; point for these uses. However, for convenience, jsonrpc.el comes
+;; built-in with `jsonrpc-process-connection' class for talking to
+;; local subprocesses (through stdin/stdout) and TCP hosts using
+;; sockets. This uses some basic HTTP-style enveloping headers for
+;; JSON objects sent over the wire. For an example of an application
+;; using this transport scheme on top of JSONRPC, see for example the
+;; Language Server Protocol
+;; (https://microsoft.github.io/language-server-protocol/specification).
;;
-;; `jsonrpc-connect' returns a connection upon connection. This value
-;; should be saved to be later given to `jsonrpc-notify',
-;; `jsonrpc-reply', `jsonrpc-request' and `jsonrpc-async-request' as a
-;; way of contacting the connected remote endpoint.
+;; Whatever the method used to obtain a `jsonrpc-connection', it is
+;; given to `jsonrpc-notify', `jsonrpc-request' and
+;; `jsonrpc-async-request' as a way of contacting the connected remote
+;; endpoint.
;;
-;; `jsonrpc-connect' is also passed a dispatcher function for handling
-;; handling the contacts asynchronously initiated by the remote
-;; endpoint's, as well as a optional function for cleaning up after
-;; the tear-down of the JSONRPC connection.
+;; For handling remotely initiated contacts, `jsonrpc-connection'
+;; objects hold dispatcher functions that the application should pass
+;; to object's constructor if it is interested in those messages.
;;
;; The JSON objects are passed to the dispatcher after being read by
-;; `json-read' of Emacs's json.el library. They are read as plists,
-;; and, likewise, json.el-compatible plists should be given to
-;; `jsonrpc-notify', `jsonrpc-request', etc...
+;; `jsonrpc--json-read', which may use either the longstanding json.el
+;; library or a newer and faster json.c library if it is available.
;;
-;; To facilitate handling of key-value plists, this library make
-;; liberal use of cl-lib.el and suggests (but doesn't force) its
-;; clients to do the same. A macro `jsonrpc-lambda' can be used to
-;; create a lambda for destructuring a JSON-object like in this
-;; example:
+;; JSON objects are exchanged as plists: plists are handed to the
+;; dispatcher functions and, likewise, plists should be given to
+;; `jsonrpc-notify', `jsonrpc-request' and `jsonrpc-async-request'.
+;;
+;; To facilitate handling plists, this library make liberal use of
+;; cl-lib.el and suggests (but doesn't force) its clients to do the
+;; same. A macro `jsonrpc-lambda' can be used to create a lambda for
+;; destructuring a JSON-object like in this example:
;;
;; (jsonrpc-async-request
;; myproc :frobnicate `(:foo "trix")
@@ -84,47 +83,6 @@
;; (message "Sadly, server reports %s: %s"
;; code message)))
;;
-;;;; Usage example:
-;;
-;; Finally, here's an example Emacs JSONRPC server that offers a (very
-;; small) subset of Elisp for remote calling:
-;;
-;; (defvar server-server) (defvar server-endpoint)
-;; (defvar server-allowed-functions '(+ - * / vconcat append sit-for))
-;;
-;; (setq server-server
-;; (make-network-process
-;; :name "Emacs RPC server" :server t :host "localhost" :service 44444
-;; :log (lambda (_server client _message)
-;; (jsonrpc-connect
-;; (process-name client)
-;; (make-instance 'jsonrpc-process-connection :process client)
-;; (lambda (endpoint method id params)
-;; (unless (memq method '(+ - * / vconcat append sit-for))
-;; (signal 'jsonrpc-error `((jsonrpc-error-message
-;; . "Sorry, this isn't allowed")
-;; (jsonrpc-error-code . -32601))))
-;; (jsonrpc-reply endpoint id :result
-;; (apply method (append params nil))))))))
-;;
-;; (setq server-endpoint (jsonrpc-connect
-;; "Emacs RPC client" '("localhost" 9393)
-;; (lambda (endpoint method id &rest params)
-;; (message "server wants to %s" method))))
-;;
-;; ;; returns 3
-;; (jsonrpc-request server-endpoint '+ '(1 2))
-;; ;; errors with -32601
-;; (jsonrpc-request server-endpoint 'delete-directory "~/tmp")
-;; ;; signals an -32603 JSONRPC error
-;; (jsonrpc-request server-endpoint '+ '(a 2))
-;; ;; times out
-;; (jsonrpc-request server-endpoint 'sit-for '(5))
-;; ;; stretching it, but works
-;; (jsonrpc-request server-endpoint 'vconcat '([1 2 3] [3 4 5]))
-;; ;; json.el can't serialize this, json.el errors and request isn't sent
-;; (jsonrpc-request server-endpoint 'append '((1 2 3) (3 4 5)))
-;;
;;; Code:
(require 'cl-lib)
@@ -175,13 +133,22 @@ FORMAT as the message."
(apply #'format format args)
:warning)))
+;;;###autoload
(defclass jsonrpc-connection ()
((name
:accessor jsonrpc-name
+ :initarg :name
:documentation "A name for the connection")
- (-dispatcher
- :accessor jsonrpc--dispatcher
- :documentation "Emacs-lisp function for server-invoked methods.")
+ (-request-dispatcher
+ :accessor jsonrpc--request-dispatcher
+ :initform #'ignore
+ :initarg :request-dispatcher
+ :documentation "Dispatcher for remotely invoked requests.")
+ (-notification-dispatcher
+ :accessor jsonrpc--notification-dispatcher
+ :initform #'ignore
+ :initarg :notification-dispatcher
+ :documentation "Dispatcher for remotely invoked notifications.")
(status
:initform `(:unknown nil) :accessor jsonrpc-status
:documentation "Status (WHAT SERIOUS-P) as declared by the server.")
@@ -189,18 +156,9 @@ FORMAT as the message."
:initform (make-hash-table)
:accessor jsonrpc--request-continuations
:documentation "A hash table of request ID to continuation lambdas.")
- (-server-request-ids
- :accessor jsonrpc--server-request-ids
- :documentation "Server-initiated request ids that client hasn't replied
to.")
(-events-buffer
:accessor jsonrpc--events-buffer
:documentation "A buffer pretty-printing the JSON-RPC RPC events")
- (contact
- :accessor jsonrpc-contact
- :documentation "Method used to contact a server.")
- (-on-shutdown
- :accessor jsonrpc--on-shutdown
- :documentation "Function run when JSONRPC server is dying.")
(-deferred-actions
:initform (make-hash-table :test #'equal)
:accessor jsonrpc--deferred-actions
@@ -210,16 +168,65 @@ than TIMER as ID.")
(-next-request-id
:initform 0
:accessor jsonrpc--next-request-id
- :documentation "Next number used for a request")))
+ :documentation "Next number used for a request"))
+ :documentation "Base class representing a JSONRPC connection.
+The following initargs are accepted:
+
+:NAME (mandatory), a string naming the connection
+
+:REQUEST-DISPATCHER (optional), a function of three
+arguments (CONN METHOD PARAMS) for handling JSONRPC requests.
+CONN is a `jsonrpc-connection' object, method is a symbol, and
+PARAMS is a plist representing a JSON object. The function is
+expected to call `jsonrpc-reply' or signal an error of type
+`jsonrpc-error'.
+:NOTIFICATION-DISPATCHER (optional), a function of three
+arguments (CONN METHOD PARAMS) for handling JSONRPC
+notifications. CONN, METHOD and PARAMS are the same as in
+:REQUEST-DISPATCHER.")
+
+;;;###autoload
(defclass jsonrpc-process-connection (jsonrpc-connection)
((-process
:initarg :process :accessor jsonrpc--process
- ;; :initform (error "`:process' is a required initarg") ; doesn't work
:documentation "Process object wrapped by the this connection.")
(-expected-bytes
:accessor jsonrpc--expected-bytes
- :documentation "How many bytes declared by server")))
+ :documentation "How many bytes declared by server")
+ (-on-shutdown
+ :accessor jsonrpc--on-shutdown
+ :initform #'ignore
+ :initarg :on-shutdown
+ :documentation "Function run when the process dies."))
+ :documentation "A JSONRPC connection over an Emacs process.
+The following initargs are accepted:
+
+:PROCESS (mandatory), a live running Emacs process object or a
+function of no arguments producing one such object. The process
+represents either a pipe connection to locally running process or
+a stream connection to a network host. The remote endpoint is
+expected to understand JSONRPC messages with basic HTTP-style
+enveloping headers such as \"Content-Length:\".
+
+:ON-SHUTDOWN (optional), a function of one argument, the
+connection object, called when the process dies .")
+
+(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots)
+ (cl-call-next-method)
+ (let* ((proc (plist-get slots :process))
+ (proc (if (functionp proc) (funcall proc) proc))
+ (buffer (get-buffer-create (format "*%s output*" (process-name
proc))))
+ (stderr (get-buffer-create (format "*%s stderr*" (process-name
proc)))))
+ (setf (jsonrpc--process conn) proc)
+ (set-process-buffer proc buffer)
+ (process-put proc 'jsonrpc-stderr stderr)
+ (set-process-filter proc #'jsonrpc--process-filter)
+ (set-process-sentinel proc #'jsonrpc--process-sentinel)
+ (with-current-buffer (process-buffer proc)
+ (set-marker (process-mark proc) (point-min))
+ (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc))
+ (process-put proc 'jsonrpc-connection conn)))
(defmacro jsonrpc-obj (&rest what)
"Make WHAT a suitable argument for `json-encode'."
@@ -228,96 +235,26 @@ than TIMER as ID.")
;; the indenting of literal plists, i.e. is basically `list'
`(list ,@what))
-;;;###autoload
-(cl-defun jsonrpc-connect (name contact dispatcher &optional on-shutdown)
- "Connect to JSONRPC endpoint NAME through CONTACT.
-
-This function creates an object (subprocess or network
-connection) wrapped in a `jsonrpc-process-connection' object.
-
-NAME is a string naming the connection.
-
-In the most common case CONTACT is a list of strings (COMMAND
-ARGS...) specifying how to locally start a server subprocess to
-talk to via JSONRPC. If the second element in the list is an
-integer number instead of a string, the list is interpreted
-as (HOST PORT PARAMETERS...) and an attempt is made to contact
-HOST on PORT, with the remaining PARAMETERS are given to
-`open-network-stream's optional arguments.
-
-Moreover, if in either of these cases the first element in the
-list is a symbol, that symbol is taken to name a subclass of
-`jsonrpc-process-connection' which is used to create the object
-returned by this function. The remaining arguments are processed
-as described in the previous paragraph.
-
-CONTACT can also be a an object of the type
-`jsonrpc-process-connection' (or a subclass thereof) containing a
-pre-connected process object. In that case the processes buffer,
-filter and sentinel are henceforth overwritten and managed by
-`jsonrpc-connect'.
-
-ON-SHUTDOWN, if non-nil, is a function called on server exit and
-passed the moribund connection object as a single argument.
-
-DISPATCHER specifies how the server-invoked methods find their
-Elisp counterpart. It is a function passed (PROC METHOD ID PARAMS
-as arguments. PROC is the connection object returned by this
-function. ID is the server identifier for a server request, or
-nil for a server notification. METHOD is a symbol. PARAMS
-contains the method parameters as JSON data.
-
-If ID is non-nil, DISPATCHER is expected to reply to the
-request. If it doesn't, or if it signals an error before doing
-so, jsonrpc.el will automatically reply with an error. If DISPATCHER
-signals an error with alist elements `jsonrpc-error-message' and
-`jsonrpc-error-code' in its DATA, the corresponding elements are
-used for the automated error reply.
-
-If successful, `jsonrpc-connect' returns a
-`jsonrpc-process-connection' object representing the remote
-endpoint."
- (let* ((readable-name (format "JSON-RPC server (%s)" name))
- (buffer (get-buffer-create (format "*%s output*" readable-name)))
- (stderr)
- (original-contact contact)
- (connection
- (cond
- ((cl-typep contact 'jsonrpc-process-connection)
- (unless (process-live-p (jsonrpc--process contact))
- (error "%s doesn't have a live process" contact))
- contact)
- ((listp contact)
- (make-instance
- (if (symbolp (car contact))
- (prog1 (car contact) (setq contact (cdr contact)))
- 'jsonrpc-process-connection)
- :process
- (cond ((integerp (cadr contact))
- (apply #'open-network-stream readable-name buffer contact))
- (t
- (make-process :name readable-name
- :command contact
- :connection-type 'pipe
- :coding 'no-conversion
- :stderr (setq stderr
- (get-buffer-create
- (format "*%s stderr*"
name))))))))))
- (proc (jsonrpc--process connection)))
- (set-process-buffer proc buffer)
- (process-put proc 'jsonrpc-stderr stderr)
- (set-marker (process-mark proc) (with-current-buffer buffer (point-min)))
- (set-process-filter proc #'jsonrpc--process-filter)
- (set-process-sentinel proc #'jsonrpc--process-sentinel)
- (with-current-buffer buffer
- (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc))
- (process-put proc 'jsonrpc-connection connection)
- (setf (jsonrpc--process connection) proc
- (jsonrpc-contact connection) original-contact
- (jsonrpc-name connection) name
- (jsonrpc--dispatcher connection) dispatcher
- (jsonrpc--on-shutdown connection) (or on-shutdown #'ignore))
- connection))
+(defun jsonrpc--json-read ()
+ "Read JSON object in buffer, move point to end of buffer."
+ ;; TODO: I guess we can make these macros if/when jsonrpc.el
+ ;; goes into Emacs core.
+ (cond ((fboundp 'json-parse-buffer) (json-parse-buffer
+ :object-type 'plist
+ :null-object nil
+ :false-object :json-false))
+ (t (let ((json-object-type 'plist))
+ (json-read)))))
+
+(defun jsonrpc--json-encode (object)
+ "Encode OBJECT into a JSON string."
+ (cond ((fboundp 'json-serialize) (json-serialize
+ object
+ :false-object :json-false
+ :null-object nil))
+ (t (let ((json-false :json-false)
+ (json-null nil))
+ (json-encode object)))))
(defun jsonrpc--process-sentinel (proc change)
"Called when PROC undergoes CHANGE."
@@ -387,10 +324,9 @@ endpoint."
(unwind-protect
(save-restriction
(narrow-to-region (point) message-end)
- (let* ((json-object-type 'plist)
- (json-message
+ (let* ((json-message
(condition-case-unless-debug oops
- (json-read)
+ (jsonrpc--json-read)
(error
(jsonrpc-warn "Invalid JSON: %s %s"
(cdr oops)
(buffer-string))
@@ -464,56 +400,71 @@ originated."
(setq msg (propertize msg 'face 'error)))
(insert-before-markers msg))))))
+(defvar jsonrpc--unanswered-request-id)
+
(defun jsonrpc--connection-receive (connection message)
"Connection MESSAGE from CONNECTION."
- (pcase-let ((`(,method ,id ,error ,params ,result)
+ (cl-destructuring-bind
+ (&key method id error params result _jsonrpc)
+ message
+ (pcase-let* ((continuations)
+ (lisp-err)
+ (jsonrpc--unanswered-request-id id))
+ (jsonrpc-log-event connection message 'server)
+ (when error (setf (jsonrpc-status connection) `(,error t)))
+ (cond (method
+ (let ((debug-on-error
+ (and debug-on-error
+ (not (ert-running-test)))))
(condition-case-unless-debug oops
- (cl-destructuring-bind
- (&rest args &key method id error params result _jsonrpc)
- message (list method id error params result))
- (error (jsonrpc-warn "Invalid JSONRPC message %s: %s" message
- (cdr oops))
- nil)))
- (continuations)
- (lisp-err))
- (jsonrpc-log-event connection message 'server)
- (when error (setf (jsonrpc-status connection) `(,error t)))
- (cond (method
- (let ((debug-on-error
- (and debug-on-error
- (not (ert-running-test)))))
- (condition-case-unless-debug oops
- (funcall (jsonrpc--dispatcher connection)
- connection (intern method) id params)
- (error (setq lisp-err oops))))
- (unless (or (member id (jsonrpc--server-request-ids connection))
- (not (or id lisp-err)))
- (jsonrpc-reply
- connection id
- :error (jsonrpc-obj
- :code (or (alist-get 'jsonrpc-error-code (cdr lisp-err))
- -32603)
- :message (or (alist-get 'jsonrpc-error-message
- (cdr lisp-err))
- "Internal error"))))
- (setf (jsonrpc--server-request-ids connection)
- (delete id (jsonrpc--server-request-ids connection))))
- ((setq continuations
- (and id (gethash id (jsonrpc--request-continuations
connection))))
- (let ((timer (nth 2 continuations)))
- (when timer (cancel-timer timer)))
- (remhash id (jsonrpc--request-continuations connection))
- (if error (funcall (nth 1 continuations) error)
- (funcall (nth 0 continuations) result)))
- (id
- (jsonrpc-warn "No continuation for id %s" id)))
- (jsonrpc--call-deferred connection)))
+ (funcall (if id
+ (jsonrpc--request-dispatcher connection)
+ (jsonrpc--notification-dispatcher connection))
+ connection (intern method) params)
+ (error
+ (setq lisp-err oops))))
+ (unless (or (not jsonrpc--unanswered-request-id)
+ (not lisp-err))
+ (jsonrpc-reply
+ connection
+ :error (jsonrpc-obj
+ :code (or (alist-get 'jsonrpc-error-code (cdr
lisp-err))
+ -32603)
+ :message (or (alist-get 'jsonrpc-error-message
+ (cdr lisp-err))
+ "Internal error")))))
+ ((setq continuations
+ (and id (gethash id (jsonrpc--request-continuations
connection))))
+ (let ((timer (nth 2 continuations)))
+ (when timer (cancel-timer timer)))
+ (remhash id (jsonrpc--request-continuations connection))
+ (if error (funcall (nth 1 continuations) error)
+ (funcall (nth 0 continuations) result)))
+ (id
+ (jsonrpc-warn "No continuation for id %s" id)))
+ (jsonrpc--call-deferred connection))))
(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
- message)
+ &rest args
+ &key
+ id
+ method
+ params
+ result
+ error)
"Send MESSAGE, a JSON object, to CONNECTION."
- (let ((json-object-type 'plist)
- (json (json-encode message)))
+ (let* ((method
+ (cond ((keywordp method)
+ (substring (symbol-name method) 1))
+ ((and method (symbolp method)) (symbol-name method))
+ (t method)))
+ (message `(:jsonrpc "2.0"
+ ,@(when method `(:method ,method))
+ ,@(when id `(:id ,id))
+ ,@(when params `(:params ,params))
+ ,@(when result `(:result ,result))
+ ,@(when error `(:error ,error))))
+ (json (jsonrpc--json-encode message)))
(process-send-string (jsonrpc--process connection)
(format "Content-Length: %d\r\n\r\n%s"
(string-bytes json)
@@ -632,10 +583,10 @@ TIMEOUT is nil)."
(cl-return-from jsonrpc--async-request-1 (list id timer))))
;; Really send it
;;
- (jsonrpc-connection-send connection (jsonrpc-obj :jsonrpc "2.0"
- :id id
- :method method
- :params params))
+ (jsonrpc-connection-send connection
+ :id id
+ :method method
+ :params params)
(puthash id
(list (or success-fn
(jsonrpc-lambda (&rest _ignored)
@@ -695,20 +646,20 @@ DEFERRED is passed to `jsonrpc-async-request', which see."
(cl-defun jsonrpc-notify (connection method params)
"Notify CONNECTION of something, don't expect a reply.e"
- (jsonrpc-connection-send connection (jsonrpc-obj :jsonrpc "2.0"
- :method method
- :params params)))
+ (jsonrpc-connection-send connection
+ :method method
+ :params params))
-(cl-defun jsonrpc-reply (connection id &key (result nil result-supplied-p)
error)
+(cl-defun jsonrpc-reply (connection &key (result nil result-supplied-p) error)
"Reply to CONNECTION's request ID with RESULT or ERROR."
- (unless id (jsonrpc-error "Need a non-nil ID"))
(unless (xor result-supplied-p error)
(jsonrpc-error "Can't pass both RESULT and ERROR!"))
- (push id (jsonrpc--server-request-ids connection))
(jsonrpc-connection-send
- connection `(:jsonrpc "2.0" :id ,id
- ,@(when result `(:result ,result))
- ,@(when error `(:error ,error)))))
+ connection
+ :id jsonrpc--unanswered-request-id
+ :result result
+ :error error)
+ (setq jsonrpc--unanswered-request-id nil))
(provide 'jsonrpc)
;;; jsonrpc.el ends here
