mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-06-14 20:41:23 +00:00
9b3855e164
When the remote endpoint is handling a local request 'LR' it can sometimes make a remote sync request 'RR' as part of its handling. Some endpoints (like Go's gopls) wait for Emacs's reply to 'RR' before responding to 'LR'. Others (like Julia's JETLS) respond to 'LR' immediately, and only then wait for Emacs's reply to 'RR'. Both approaches are valid. However, in the latter case, the handling of 'RR' (which could well be waiting for user input from the minibuffer to complete) is vulnerable to 'throw' from process filters handling (which is just what happens when the endpoints replies to 'LR'), so if that happens it will unexpectedly be aborted when the reply to 'LR' comes in, suprising the user and causing a spurious -32603 reply to be sent. To solve this problem, this commit first refactors the sync request/anxious queue handling and replace plain integer keys of the rebaptized "scontrol" alist with structured (:local ID) / (:remote ID) pairs, using `equal' for comparisons. This is to introduce some clarity/sanity into this somewhat hairy code. Then, the 'RR' situation is fixed: we push a (:remote ID) entry onto the top of the 'jsonrpc-connection--control' stack and only then call rdispatcher. Any 'LR' reply arriving during dispatch is deferred as an "anxious" continuation rather than firing its `throw' immediately. When rdispatcher is done, we call jsonrpc--continue at a safe point, this will run any "anxious" continuations. * lisp/jsonrpc.el (jsonrpc-connection): Rename -sync-request-alist to -scontrol; accessor from jsonrpc--sync-request-alist to jsonrpc--scontrol; update docstring for new key structure. (jsonrpc-connection-receive): Update with-slots binding to scontrol. Tighten anxious check to match (:local ID) keys with `equal'. In remote-request branch, push (:remote ID) entry before rdispatcher and call jsonrpc--continue after jsonrpc--reply. (jsonrpc-request): Pass (:local ID) to jsonrpc--continue. (jsonrpc--continue): Use jsonrpc--scontrol; change `=' to `equal' in sanity check. p (jsonrpc--async-request-1): Push (:local ID) entry. (jsonrpc--log-event): Use jsonrpc--scontrol.
1276 lines
54 KiB
EmacsLisp
1276 lines
54 KiB
EmacsLisp
;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2018-2026 Free Software Foundation, Inc.
|
||
|
||
;; Author: João Távora <joaotavora@gmail.com>
|
||
;; Keywords: processes, languages, extensions
|
||
;; Version: 1.0.28
|
||
;; Package-Requires: ((emacs "25.2"))
|
||
|
||
;; This is a GNU ELPA :core package. Avoid functionality that is not
|
||
;; compatible with the version of Emacs recorded above.
|
||
|
||
;; This file is part of GNU Emacs.
|
||
|
||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; This library implements the JSONRPC 2.0 specification as described
|
||
;; in https://www.jsonrpc.org/. As the name suggests, JSONRPC is a
|
||
;; generic Remote Procedure Call protocol designed around JSON
|
||
;; objects. To learn how to write JSONRPC programs with this library,
|
||
;; see Info node `(elisp)JSONRPC'."
|
||
;;
|
||
;; This library was originally extracted from eglot.el, an Emacs LSP
|
||
;; client, which you should see for an example usage.
|
||
;;
|
||
;;; Code:
|
||
|
||
(require 'cl-lib)
|
||
(require 'eieio)
|
||
(eval-when-compile (require 'subr-x))
|
||
(require 'warnings)
|
||
(require 'pcase)
|
||
|
||
|
||
;;; Public API
|
||
;;;
|
||
|
||
(defclass jsonrpc-connection ()
|
||
((name
|
||
:accessor jsonrpc-name
|
||
:initform "anonymous"
|
||
:initarg :name
|
||
:documentation "A name for the connection")
|
||
(-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.")
|
||
(last-error
|
||
:initform nil
|
||
:accessor jsonrpc-last-error
|
||
:documentation "Last JSONRPC error message received from endpoint.")
|
||
(-continuations
|
||
:initform nil
|
||
:accessor jsonrpc--continuations
|
||
:documentation "An alist of request IDs to continuation specs.")
|
||
(-events-buffer
|
||
:initform nil
|
||
:accessor jsonrpc--events-buffer
|
||
:documentation "A buffer pretty-printing the JSONRPC events")
|
||
(-events-buffer-config
|
||
:initform '(:size nil :format full)
|
||
:initarg :events-buffer-config
|
||
:documentation "Plist configuring the events buffer functions.")
|
||
(-deferred-actions
|
||
:initform (make-hash-table :test #'equal)
|
||
:accessor jsonrpc--deferred-actions
|
||
:documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\
|
||
a saved DEFERRED `async-request' from BUF, to be sent not later\
|
||
than TIMER as ID.")
|
||
(-scontrol ; bug#67945
|
||
:initform nil
|
||
:accessor jsonrpc--scontrol
|
||
:documentation "List of ((KEY [ANXIOUS...])) where KEY is \
|
||
(:local ID) for an outstanding sync `jsonrpc-request', or \
|
||
(:remote ID) while a remote request with that ID is being \
|
||
dispatched. Each ANXIOUS is a completed response deferred \
|
||
until KEY's entry is popped.")
|
||
(-next-request-id
|
||
:initform 0
|
||
:accessor jsonrpc--next-request-id
|
||
:documentation "Next number used for a request"))
|
||
:documentation "Base class representing a JSONRPC connection.
|
||
The following keyword argument 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 return a JSONRPC result, a plist of (:result
|
||
RESULT) 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.
|
||
|
||
:EVENTS-BUFFER-CONFIG is a plist. Its `:size' stipulates the
|
||
size of the log buffer (0 disables, nil means infinite). The
|
||
`:format' property is a symbol for choosing the log entry format.")
|
||
|
||
(cl-defmethod initialize-instance :after
|
||
((c jsonrpc-connection) ((&key (events-buffer-scrollback-size
|
||
nil
|
||
e-b-s-s-supplied-p)
|
||
&allow-other-keys)
|
||
t))
|
||
(when e-b-s-s-supplied-p
|
||
(warn
|
||
"`:events-buffer-scrollback-size' deprecated. Use `events-buffer-config'.")
|
||
(with-slots ((plist -events-buffer-config)) c
|
||
(setf plist (copy-sequence plist)
|
||
plist (plist-put plist :size events-buffer-scrollback-size)))))
|
||
|
||
(cl-defmethod slot-missing ((_c jsonrpc-connection)
|
||
(_n (eql :events-buffer-scrollback-size))
|
||
(_op (eql oset))
|
||
_)
|
||
;; Yuck! But this just coerces EIEIO to backward-compatibly accept
|
||
;; the :e-b-s-s initarg that is no longer associated with a slot
|
||
;; #pineForCLOS..
|
||
)
|
||
|
||
;;; API mandatory
|
||
(cl-defgeneric jsonrpc-connection-send (conn &key id method params result error)
|
||
"Send a JSONRPC message to connection CONN.
|
||
ID, METHOD, PARAMS, RESULT and ERROR.")
|
||
|
||
;;; API optional
|
||
(cl-defgeneric jsonrpc-shutdown (conn)
|
||
"Shutdown the JSONRPC connection CONN.")
|
||
|
||
;;; API optional
|
||
(cl-defgeneric jsonrpc-running-p (conn)
|
||
"Tell if the JSONRPC connection CONN is still running.")
|
||
|
||
;;; API optional
|
||
(cl-defgeneric jsonrpc-connection-ready-p (connection what)
|
||
"Tell if CONNECTION is ready for WHAT in current buffer.
|
||
If it isn't, a request which was passed a value to the
|
||
`:deferred' keyword argument will be deferred to the future.
|
||
WHAT is whatever was passed the as the value to that argument.
|
||
|
||
By default, all connections are ready for sending all requests
|
||
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)
|
||
(cl-loop for (k v) on remote-message by #'cddr
|
||
unless (eq k :jsonrpc-json)
|
||
collect k and collect v)))
|
||
|
||
|
||
;;; Convenience
|
||
;;;
|
||
(cl-defmacro jsonrpc-lambda (cl-lambda-list &body body)
|
||
(declare (indent 1) (debug (sexp &rest form)))
|
||
(let ((e (funcall (if (fboundp 'gensym) 'gensym 'cl-gensym)
|
||
"jsonrpc-lambda-elem")))
|
||
`(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e))))
|
||
|
||
(defun jsonrpc-events-jq-at-point ()
|
||
"Find first { in line, use forward-sexp to grab JSON, pipe through jq."
|
||
(interactive)
|
||
(save-excursion
|
||
(beginning-of-line)
|
||
(when (search-forward "{" (line-end-position) t)
|
||
(backward-char)
|
||
(let ((start (point)))
|
||
(forward-sexp)
|
||
(shell-command-on-region start (point) "jq" "*jq output*")))))
|
||
|
||
(defun jsonrpc-events-occur-at-point ()
|
||
"Run occur on thing at point."
|
||
(interactive)
|
||
(occur (thing-at-point 'symbol)))
|
||
|
||
(defvar jsonrpc-events-mode-map
|
||
(let ((map (make-sparse-keymap)))
|
||
(define-key map (kbd "RET") 'jsonrpc-events-jq-at-point)
|
||
(define-key map (kbd "C-c C-o") 'jsonrpc-events-occur-at-point)
|
||
map)
|
||
"Keymap for `jsonrpc-events-mode'.")
|
||
|
||
(define-derived-mode jsonrpc-events-mode special-mode "JSONRPC-Events"
|
||
"Major mode for JSONRPC events buffers."
|
||
(buffer-disable-undo)
|
||
(setq buffer-read-only t))
|
||
|
||
(defun jsonrpc-events-buffer (connection)
|
||
"Get or create JSONRPC events buffer for CONNECTION."
|
||
(let ((probe (jsonrpc--events-buffer connection)))
|
||
(if (buffer-live-p probe)
|
||
probe
|
||
(with-current-buffer
|
||
(get-buffer-create (format "*%s events*" (jsonrpc-name connection)))
|
||
(jsonrpc-events-mode)
|
||
(setf (jsonrpc--events-buffer connection)
|
||
(current-buffer))))))
|
||
|
||
(defun jsonrpc-forget-pending-continuations (connection)
|
||
"Stop waiting for responses from the current JSONRPC CONNECTION."
|
||
(setf (jsonrpc--continuations connection) nil))
|
||
|
||
(defvar jsonrpc-inhibit-debug-on-error nil
|
||
"Inhibit `debug-on-error' when answering requests.
|
||
Some extensions, notably ert.el, set `debug-on-error' to non-nil,
|
||
which makes it hard to test the behavior of catching the Elisp
|
||
error and replying to the endpoint with an JSONRPC-error. This
|
||
variable can be set around calls like `jsonrpc-request' to
|
||
circumvent that.")
|
||
|
||
(defun jsonrpc-connection-receive (conn foreign-message)
|
||
"Process FOREIGN-MESSAGE just received from CONN.
|
||
This function will destructure MESSAGE and call the appropriate
|
||
dispatcher in CONN."
|
||
(cl-destructuring-bind (&rest whole &key method id error params result _jsonrpc)
|
||
(jsonrpc-convert-from-endpoint conn foreign-message)
|
||
(unwind-protect
|
||
(let* ((log-plist (list :json (plist-get foreign-message :jsonrpc-json)
|
||
:kind (cond ((and method id) 'request)
|
||
(method 'notification)
|
||
(id 'reply))
|
||
:message whole
|
||
:foreign-message foreign-message))
|
||
(response-p (and (null method) id))
|
||
(cont (and response-p (jsonrpc--remove conn id))))
|
||
(cl-remf foreign-message :jsonrpc-json)
|
||
;; Do this pre-processing of the response so we can always
|
||
;; log richer information _before_ any non-local calls
|
||
;; further ahead. Putting the `jsonrpc--event' as
|
||
;; an unwind-form would make us log after the fact.
|
||
(when cont
|
||
(pcase-let ((`(,_ ,method ,_ ,_ ,_) cont))
|
||
(if (keywordp method)
|
||
(setq method (substring (symbol-name method) 1)))
|
||
;; TODO: also set the depth
|
||
(setq whole (plist-put whole :method method))))
|
||
|
||
;; Do the logging
|
||
(apply #'jsonrpc--event conn 'server log-plist)
|
||
(with-slots (last-error
|
||
(rdispatcher -request-dispatcher)
|
||
(ndispatcher -notification-dispatcher)
|
||
(scontrol -scontrol))
|
||
conn
|
||
(setf last-error error)
|
||
(cond
|
||
(;; A remote response whose request has been canceled
|
||
;; (i.e. timeout or C-g)
|
||
;;
|
||
(and response-p (null cont))
|
||
(jsonrpc--event
|
||
conn 'internal
|
||
:log-text
|
||
(format "Response to request %s which has been canceled"
|
||
id)
|
||
:id id)
|
||
;; TODO: food for thought: this seems to be also where
|
||
;; notifying the server of the cancellation would come
|
||
;; in.
|
||
)
|
||
(;; A remote response that can't run yet (bug#67945)
|
||
(and response-p
|
||
(and scontrol (not (equal `(:local ,id) (caar scontrol)))))
|
||
(jsonrpc--event
|
||
conn 'internal
|
||
:log-text
|
||
(format "anxious continuation to %s can't run, held up by %s"
|
||
id
|
||
(mapcar #'car scontrol)))
|
||
(push (cons cont (list result error))
|
||
(cdr (car scontrol))))
|
||
(;; A remote response that can continue now
|
||
response-p
|
||
(jsonrpc--continue conn `(:local ,id) cont result error))
|
||
(;; A remote request
|
||
(and method id)
|
||
(let* ((debug-on-error (and debug-on-error
|
||
(not jsonrpc-inhibit-debug-on-error)))
|
||
reply)
|
||
;; While the rdispatcher runs, any arriving response to
|
||
;; a previous sync request must not fire its
|
||
;; continuation immediately: the resulting `throw' would
|
||
;; unwind through the dispatcher and trigger a spurious
|
||
;; -32603 instead of a reply. Use `jsonrpc--scontrol'
|
||
;; mechanism to defer such continuations until the end
|
||
;; of the cleanup below.
|
||
(push `((:remote ,id)) (jsonrpc--scontrol conn))
|
||
(unwind-protect
|
||
(setq
|
||
reply
|
||
(condition-case oops
|
||
`(:result
|
||
,(funcall rdispatcher conn (intern method) params))
|
||
(jsonrpc-error
|
||
(let* ((data (cdr oops))
|
||
(code (alist-get 'jsonrpc-error-code data))
|
||
(msg (alist-get 'jsonrpc-error-message
|
||
(cdr oops))))
|
||
(if (eq code 32000) ;; This means 'no error'
|
||
(when-let* ((d (alist-get 'jsonrpc-error-data
|
||
data)))
|
||
`(:result ,d))
|
||
`(:error
|
||
(:code ,(or code -32603)
|
||
:message ,(or msg "Internal error"))))))))
|
||
(unless reply
|
||
(setq reply
|
||
`(:error (:code -32603 :message "Internal error"))))
|
||
(apply #'jsonrpc--reply conn id method reply)
|
||
(jsonrpc--continue conn `(:remote ,id)))))
|
||
(;; A remote notification
|
||
method
|
||
(funcall ndispatcher conn (intern method) params))
|
||
(t
|
||
(jsonrpc--event conn 'internal
|
||
:log-text "Malformed message" )))))
|
||
(jsonrpc--call-deferred conn))))
|
||
|
||
|
||
;;; Contacting the remote endpoint
|
||
;;;
|
||
(defun jsonrpc-error (&rest args)
|
||
"Error out with FORMAT and ARGS.
|
||
If invoked inside a dispatcher function, this function is suitable
|
||
for replying to the remote endpoint with an error message.
|
||
|
||
ARGS can be of the form (FORMAT-STRING . MOREARGS) for replying
|
||
with a -32603 error code and a message formed by formatting
|
||
FORMAT-STRING with MOREARGS.
|
||
|
||
Alternatively ARGS can be plist representing a JSONRPC error
|
||
object, using the keywords `:code', `:message' and `:data'."
|
||
(if (stringp (car args))
|
||
(let ((msg
|
||
(apply #'format-message (car args) (cdr args))))
|
||
(signal 'jsonrpc-error
|
||
`(,msg
|
||
(jsonrpc-error-code . -32603)
|
||
(jsonrpc-error-message . ,msg))))
|
||
(cl-destructuring-bind (&key code message data) args
|
||
(signal 'jsonrpc-error
|
||
`("[jsonrpc] error "
|
||
(jsonrpc-error-code . ,code)
|
||
(jsonrpc-error-message . ,message)
|
||
(jsonrpc-error-data . ,data))))))
|
||
|
||
(cl-defun jsonrpc-async-request (connection
|
||
method
|
||
params
|
||
&rest args
|
||
&key _success-fn _error-fn
|
||
_timeout-fn
|
||
_timeout _deferred)
|
||
"Make a request to CONNECTION, expecting a reply, return immediately.
|
||
The JSONRPC request is formed by METHOD, a symbol; and PARAMS, a JSON
|
||
object value as described in `json-serialize' (which see).
|
||
|
||
The caller can expect SUCCESS-FN or ERROR-FN to be called with a
|
||
JSONRPC `:result' or `:error' object, respectively. If this
|
||
doesn't happen after TIMEOUT seconds (defaults to
|
||
`jrpc-default-request-timeout'), the caller can expect TIMEOUT-FN
|
||
to be called with no arguments. The default values of SUCCESS-FN,
|
||
ERROR-FN and TIMEOUT-FN simply log the events into
|
||
`jsonrpc-events-buffer'.
|
||
|
||
If DEFERRED is non-nil, maybe defer the request to a future time
|
||
when the server is thought to be ready according to
|
||
`jsonrpc-connection-ready-p' (which see). The request might
|
||
never be sent at all, in case it is overridden in the meantime by
|
||
a new request with identical DEFERRED and for the same buffer.
|
||
However, in that situation, the original timeout is kept.
|
||
|
||
PARAMS can also be the keyword `:jsonrpc-omit', in which case the
|
||
JSONRPC request object is formed without a `params' entry.
|
||
|
||
Returns a list whose first element is an integer identifying the request
|
||
as specified in the JSONRPC 2.0 spec."
|
||
(apply #'jsonrpc--async-request-1 connection method params args))
|
||
|
||
(cl-defun jsonrpc-request (connection
|
||
method params
|
||
&rest args
|
||
&key
|
||
deferred timeout
|
||
cancel-on-quit
|
||
cancel-on-input
|
||
cancel-on-input-retval)
|
||
"Make a request to CONNECTION, synchronously wait for a reply.
|
||
CONNECTION, METHOD, PARAMS, DEFERRED and TIMEOUT are interpreted as in
|
||
`jsonrpc-async-request', which see.
|
||
|
||
This function has two exit modes: local and non-local. Except for
|
||
CANCEL-ON-INPUT, explained below, the only normal local exit occurs when
|
||
the remote endpoint succeeds, in which case a JSONRPC result object is
|
||
returned. A remote endpoint error or a local timeout cause a non-local
|
||
exit with a `jsonrpc-error' condition.
|
||
|
||
A user quit (`'C-g'/`keyboard-quit') causes a non-local exit with a
|
||
`quit' condition. A non-nil CANCEL-ON-QUIT must be a function of a
|
||
single argument, ID, which identifies the request as specified in the
|
||
JSONRPC 2.0 spec. Callers may use this function to issue a cancel
|
||
notification to the endpoint, thus preventing it from continuing to work
|
||
on the request.
|
||
|
||
If CANCEL-ON-INPUT is non-nil and any type of user input is detected
|
||
while waiting for a response `jsonrpc-request' locally exits
|
||
immediately, returning CANCEL-ON-INPUT-RETVAL. CANCEL-ON-INPUT can also
|
||
be a function with the same semantics as CANCEL-ON-QUIT. Since the a
|
||
`C-g'/`keyboard-quit' also counts as user input, CANCEL-ON-INPUT
|
||
nullifies the effect of CANCEL-ON-QUIT.
|
||
|
||
On either cancellation scenario, any future remote endpoint replies
|
||
to the original request (normal or error) are ignored."
|
||
(let* ((tag (funcall (if (fboundp 'gensym) 'gensym 'cl-gensym)
|
||
"jsonrpc-request-catch-tag"))
|
||
id-and-timer
|
||
canceled
|
||
(throw-on-input nil)
|
||
retval)
|
||
(unwind-protect
|
||
(catch tag
|
||
(setq
|
||
id-and-timer
|
||
(apply
|
||
#'jsonrpc--async-request-1
|
||
connection method params
|
||
:sync-request t
|
||
:success-fn (lambda (result)
|
||
(unless canceled
|
||
(setq retval `(done ,result))
|
||
(throw tag nil)))
|
||
:error-fn
|
||
(jsonrpc-lambda
|
||
(&key code message data)
|
||
(unless canceled
|
||
(setq retval `(error (jsonrpc-error-code . ,code)
|
||
(jsonrpc-error-message . ,message)
|
||
(jsonrpc-error-data . ,data)))
|
||
(throw tag nil)))
|
||
:timeout-fn
|
||
(lambda ()
|
||
(unless canceled
|
||
(setq retval '(error (jsonrpc-error-message . "Timed out")))
|
||
(throw tag nil)))
|
||
`(,@(when (plist-member args :deferred) `(:deferred ,deferred))
|
||
,@(when (plist-member args :timeout) `(:timeout ,timeout)))))
|
||
(cond (cancel-on-input
|
||
(unwind-protect
|
||
(let ((inhibit-quit t) (inhibit-redisplay t))
|
||
(while (sit-for 30 t)))
|
||
(setq canceled t))
|
||
(when (functionp cancel-on-input)
|
||
(funcall cancel-on-input (car id-and-timer)))
|
||
(setq retval `(canceled ,cancel-on-input-retval)))
|
||
(t (let ((inhibit-quit nil))
|
||
(while t (accept-process-output nil 30))))))
|
||
;; In normal operation, continuations for error/success is
|
||
;; handled by `jsonrpc--continue'. Timeouts also remove
|
||
;; the continuation...
|
||
(pcase-let* ((`(,id ,_) id-and-timer))
|
||
;; ...but we still have to guard against exist explicit
|
||
;; user-quit (C-g) or the `cancel-on-input' case, so
|
||
;; discard the continuation.
|
||
(jsonrpc--remove connection id (list deferred (current-buffer)))
|
||
;; Furthermore, assume a nil `retval' is a quit from
|
||
;; `accept-process-output' (either "soft" or "hard," like a
|
||
;; double C-g C-g on TTY terminals)
|
||
(unless retval
|
||
(when cancel-on-quit (funcall cancel-on-quit id)))
|
||
;; ...finally, whatever may have happened to this sync
|
||
;; request, it might have been holding up any outer
|
||
;; "anxious" continuations. The following ensures we
|
||
;; call them.
|
||
(jsonrpc--continue connection `(:local ,id))))
|
||
(cond ((eq 'error (car retval))
|
||
(signal 'jsonrpc-error
|
||
(cons
|
||
(format "request id=%s failed:" (car id-and-timer))
|
||
(cdr retval)))))
|
||
(cadr retval)))
|
||
|
||
(cl-defun jsonrpc-notify (connection method params)
|
||
"Notify CONNECTION of something, don't expect a reply.
|
||
CONNECTION, METHOD and PARAMS as in `jsonrpc-async-request' (which see)."
|
||
(apply #'jsonrpc-connection-send connection
|
||
:method method
|
||
(unless (eq params :jsonrpc-omit) `(:params ,params))))
|
||
|
||
(define-obsolete-variable-alias 'jrpc-default-request-timeout
|
||
'jsonrpc-default-request-timeout "28.1")
|
||
|
||
(defgroup jsonrpc nil
|
||
"JSON-RPC customization."
|
||
:prefix "jsonrpc-"
|
||
:group 'comm)
|
||
|
||
(defcustom jsonrpc-default-request-timeout 10
|
||
"Time in seconds before timing out a JSON-RPC request without response."
|
||
:version "30.1"
|
||
:type 'number
|
||
:safe 'numberp
|
||
:group 'jsonrpc)
|
||
|
||
|
||
;;; Specific to `jsonrpc-process-connection'
|
||
;;;
|
||
|
||
(defclass jsonrpc-process-connection (jsonrpc-connection)
|
||
((-process
|
||
:initarg :process :accessor jsonrpc--process
|
||
:documentation "Process object wrapped by the this connection.")
|
||
(-expected-bytes
|
||
:initform nil
|
||
:accessor jsonrpc--expected-bytes
|
||
: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.")
|
||
(-autoport-inferior
|
||
:initform nil
|
||
:documentation "Used by `jsonrpc-autoport-bootstrap'."))
|
||
:documentation "A JSONRPC connection over an Emacs process.
|
||
The following initargs are accepted:
|
||
|
||
:PROCESS (mandatory), a live running Emacs process object or a
|
||
function producing one such object. If a function, it is passed
|
||
the `jsonrpc-process-connection' 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 :after ((conn jsonrpc-process-connection) slots)
|
||
(cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots
|
||
;; FIXME: notice the undocumented bad coupling in the stderr
|
||
;; buffer name, it must be named exactly like this we expect when
|
||
;; calling `make-process'. If there were a `set-process-stderr'
|
||
;; like there is `set-process-buffer' we wouldn't need this and
|
||
;; could use a pipe with a process filter instead of
|
||
;; `after-change-functions'. Alternatively, we need a new initarg
|
||
;; (but maybe not a slot).
|
||
(let* ((stderr-buffer-name (format "*%s stderr*" name))
|
||
(stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name "[stderr] " conn))
|
||
(hidden-name (concat " " stderr-buffer-name)))
|
||
;; If we are correctly coupled to the client, the process now
|
||
;; created should pick up the `stderr-buffer' just created, which
|
||
;; we immediately rename
|
||
(setq proc (if (functionp proc)
|
||
(if (zerop (cdr (func-arity proc)))
|
||
(funcall proc)
|
||
(funcall proc conn))
|
||
proc))
|
||
(with-current-buffer stderr-buffer
|
||
(ignore-errors (kill-buffer hidden-name))
|
||
(rename-buffer hidden-name)
|
||
(setq buffer-read-only t))
|
||
(process-put proc 'jsonrpc-stderr stderr-buffer))
|
||
(setf (jsonrpc--process conn) proc)
|
||
(set-process-buffer proc (get-buffer-create (format " *%s output*" name)))
|
||
(set-process-filter proc #'jsonrpc--process-filter)
|
||
(set-process-sentinel proc #'jsonrpc--process-sentinel)
|
||
(set-process-coding-system proc 'binary 'binary)
|
||
(with-current-buffer (process-buffer proc)
|
||
(set-buffer-multibyte nil)
|
||
(buffer-disable-undo)
|
||
(set-marker (process-mark proc) (point-min))
|
||
(let ((inhibit-read-only t))
|
||
(erase-buffer))
|
||
(setq buffer-read-only t))
|
||
(process-put proc 'jsonrpc-connection conn)))
|
||
|
||
(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
|
||
&rest args
|
||
&key
|
||
id
|
||
method
|
||
_params
|
||
(_result nil result-supplied-p)
|
||
error
|
||
_partial)
|
||
"Send MESSAGE, a JSON object, to CONNECTION."
|
||
(when method
|
||
;; sanitize method into a string
|
||
(setq args
|
||
(plist-put args :method
|
||
(cond ((keywordp method) (substring (symbol-name method) 1))
|
||
((symbolp method) (symbol-name method))
|
||
((stringp method) method)
|
||
(t (error "[jsonrpc] invalid method %s" method))))))
|
||
(let* ((kind (cond ((or result-supplied-p error) 'reply)
|
||
(id 'request)
|
||
(method 'notification)))
|
||
(converted (jsonrpc-convert-to-endpoint connection args kind))
|
||
(json (jsonrpc--json-encode converted)))
|
||
(process-send-string
|
||
(jsonrpc--process connection)
|
||
(concat "Content-Length: " (number-to-string (string-bytes json)) "\r\n"
|
||
"\r\n" json))
|
||
(jsonrpc--event
|
||
connection
|
||
'client
|
||
:json json
|
||
:kind kind
|
||
:message args
|
||
:foreign-message converted)))
|
||
|
||
(defun jsonrpc-process-type (conn)
|
||
"Return the `process-type' of JSONRPC connection CONN."
|
||
(process-type (jsonrpc--process conn)))
|
||
|
||
(cl-defmethod jsonrpc-running-p ((conn jsonrpc-process-connection))
|
||
"Return non-nil if JSONRPC connection CONN is running."
|
||
(process-live-p (jsonrpc--process conn)))
|
||
|
||
(cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection)
|
||
&optional cleanup)
|
||
"Wait for JSONRPC connection CONN to shutdown.
|
||
With optional CLEANUP, kill any associated buffers.
|
||
If CONN is not shutdown within a reasonable amount of time, warn
|
||
and delete the network process."
|
||
(unwind-protect
|
||
(cl-loop
|
||
with proc = (jsonrpc--process conn) for i from 0
|
||
while (not (process-get proc 'jsonrpc-sentinel-cleanup-started))
|
||
unless (zerop i) do
|
||
(jsonrpc--warn "Sentinel for %s still hasn't run, deleting it!" proc)
|
||
(delete-process proc)
|
||
do
|
||
;; Let sentinel have a chance to run
|
||
(accept-process-output nil 0.1))
|
||
(when cleanup
|
||
(kill-buffer (process-buffer (jsonrpc--process conn)))
|
||
(kill-buffer (jsonrpc-stderr-buffer conn)))))
|
||
|
||
(defun jsonrpc-stderr-buffer (conn)
|
||
"Get CONN's standard error buffer, if any."
|
||
(process-get (jsonrpc--process conn) 'jsonrpc-stderr))
|
||
|
||
|
||
;;; Private stuff
|
||
;;;
|
||
(define-error 'jsonrpc-error "jsonrpc-error")
|
||
|
||
(defalias 'jsonrpc--json-read
|
||
(if (fboundp 'json-parse-buffer)
|
||
(lambda ()
|
||
(json-parse-buffer :object-type 'plist
|
||
:null-object nil
|
||
:false-object :json-false))
|
||
(require 'json)
|
||
(defvar json-object-type)
|
||
(declare-function json-read-from-string "json" (string))
|
||
(lambda ()
|
||
(let ((json-object-type 'plist))
|
||
;; `json-read' can't be used because the old json API requires
|
||
;; decoded input.
|
||
(prog1
|
||
(json-read-from-string
|
||
(decode-coding-string
|
||
(buffer-substring-no-properties (point) (point-max))
|
||
'utf-8-unix t))
|
||
(goto-char (point-max))))))
|
||
"Read JSON object in (binary unibyte) buffer from point.
|
||
Move point to end of buffer.")
|
||
|
||
(defalias 'jsonrpc--json-encode
|
||
(if (fboundp 'json-serialize)
|
||
(lambda (object)
|
||
(json-serialize object
|
||
:false-object :json-false
|
||
:null-object nil))
|
||
(require 'json)
|
||
(defvar json-false)
|
||
(defvar json-null)
|
||
(declare-function json-encode "json" (object))
|
||
(lambda (object)
|
||
(let ((json-false :json-false)
|
||
(json-null nil))
|
||
(json-encode object))))
|
||
"Encode OBJECT into a JSON string.")
|
||
|
||
(cl-defun jsonrpc--reply
|
||
(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))
|
||
:method ,method)))
|
||
|
||
(defun jsonrpc--call-deferred (connection)
|
||
"Call CONNECTION's deferred actions, who may again defer themselves."
|
||
(when-let* ((actions (hash-table-values (jsonrpc--deferred-actions connection))))
|
||
(jsonrpc--event
|
||
connection 'internal
|
||
:log-text (format "re-attempting deferred requests %s"
|
||
(mapcar (apply-partially #'nth 2) actions)))
|
||
(mapc #'funcall (mapcar #'car actions))))
|
||
|
||
(defun jsonrpc--process-sentinel (proc change)
|
||
"Called when PROC undergoes CHANGE."
|
||
(let ((connection (process-get proc 'jsonrpc-connection)))
|
||
(jsonrpc--debug connection "Connection state change: `%s'" change)
|
||
(when (not (process-live-p proc))
|
||
(with-current-buffer (jsonrpc-events-buffer connection)
|
||
(let ((inhibit-read-only t))
|
||
(insert "\n----------b---y---e---b---y---e----------\n")))
|
||
;; Cancel outstanding timers
|
||
(mapc (jsonrpc-lambda (_id _method _success-fn _error-fn timer)
|
||
(when timer (cancel-timer timer)))
|
||
(jsonrpc--continuations connection))
|
||
(maphash (lambda (_ triplet)
|
||
(pcase-let ((`(,_ ,timer ,_) triplet))
|
||
(when timer (cancel-timer timer))))
|
||
(jsonrpc--deferred-actions connection))
|
||
(process-put proc 'jsonrpc-sentinel-cleanup-started t)
|
||
(unwind-protect
|
||
;; Call all outstanding error handlers
|
||
(mapc (jsonrpc-lambda (_id _method _success-fn error-fn _timer)
|
||
(funcall error-fn '(:code -1 :message "Server died")))
|
||
(jsonrpc--continuations connection))
|
||
(jsonrpc--message "Server exited with status %s" (process-exit-status proc))
|
||
(delete-process proc)
|
||
(when-let* ((p (slot-value connection '-autoport-inferior))) (delete-process p))
|
||
(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* ((conn (process-get proc 'jsonrpc-connection))
|
||
(expected-bytes (jsonrpc--expected-bytes conn)))
|
||
;; Insert the text, advancing the process marker.
|
||
;;
|
||
(save-excursion
|
||
(goto-char (process-mark proc))
|
||
(let ((inhibit-read-only t)) (insert string))
|
||
(set-marker (process-mark proc) (point)))
|
||
;; Loop (more than one message might have arrived)
|
||
;;
|
||
(unwind-protect
|
||
(let (done)
|
||
(while (not done)
|
||
(cond
|
||
((not expected-bytes)
|
||
;; Starting a new message
|
||
;;
|
||
(setq expected-bytes
|
||
(and (search-forward-regexp
|
||
(rx bol "Content-Length: " (group (+ digit))
|
||
"\r\n"
|
||
(* (* (not (in ":\n"))) ": "
|
||
(* (not (in "\r\n"))) "\r\n")
|
||
"\r\n")
|
||
(+ (point) 100)
|
||
t)
|
||
(string-to-number (match-string 1))))
|
||
(unless expected-bytes
|
||
(setq done :waiting-for-new-message)))
|
||
(t
|
||
;; Attempt to complete a message body
|
||
;;
|
||
(let ((available-bytes (- (position-bytes (process-mark proc))
|
||
(position-bytes (point)))))
|
||
(cond
|
||
((>= available-bytes
|
||
expected-bytes)
|
||
(let* ((message-end (byte-to-position
|
||
(+ (position-bytes (point))
|
||
expected-bytes)))
|
||
message
|
||
)
|
||
(unwind-protect
|
||
(save-restriction
|
||
(narrow-to-region (point) message-end)
|
||
(setq message
|
||
(condition-case-unless-debug oops
|
||
(jsonrpc--json-read)
|
||
(error
|
||
(jsonrpc--warn "Invalid JSON: %s %s"
|
||
(cdr oops) (buffer-string))
|
||
nil)))
|
||
(when message
|
||
(setq message
|
||
(plist-put message :jsonrpc-json
|
||
(buffer-string)))
|
||
;; Put new messages at the front of the queue,
|
||
;; this is correct as the order is reversed
|
||
;; before putting the timers on `timer-list'.
|
||
(push message
|
||
(process-get proc 'jsonrpc-mqueue))))
|
||
(goto-char message-end)
|
||
(let ((inhibit-read-only t))
|
||
(delete-region (point-min) (point)))
|
||
(setq expected-bytes nil))))
|
||
(t
|
||
;; Message is still incomplete
|
||
;;
|
||
(setq done :waiting-for-more-bytes-in-this-message))))))))
|
||
;; 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 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
|
||
;; `timer-activate' orders timers by time, which is an
|
||
;; very expensive operation when jsonrpc-mqueue is large,
|
||
;; therefore the time object is reused for each timer
|
||
;; created.
|
||
with time = (current-time)
|
||
for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg
|
||
do (let ((timer (timer-create)))
|
||
(timer-set-time timer time)
|
||
(timer-set-function timer
|
||
(lambda (conn msg)
|
||
(with-temp-buffer
|
||
(jsonrpc-connection-receive conn msg)))
|
||
(list conn msg))
|
||
(timer-activate timer))))))))
|
||
|
||
(defun jsonrpc--remove (conn id &optional deferred-spec)
|
||
"Cancel CONN's continuations for ID, including its timer, if it exists.
|
||
Also cancel \"deferred actions\" if DEFERRED-SPEC.
|
||
Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)"
|
||
(with-slots ((conts -continuations) (defs -deferred-actions)) conn
|
||
(if deferred-spec (remhash deferred-spec defs))
|
||
(when-let* ((ass (assq id conts)))
|
||
(cl-destructuring-bind (_ _ _ _ timer) ass
|
||
(when timer (cancel-timer timer)))
|
||
(setf conts (delete ass conts))
|
||
ass)))
|
||
|
||
(defun jsonrpc--schedule (conn id method success-fn error-fn timer)
|
||
(push (list id method success-fn error-fn timer)
|
||
(jsonrpc--continuations conn)))
|
||
|
||
(defun jsonrpc--continue (conn id &optional cont result error)
|
||
(pcase-let* ((`(,cont-id ,_method ,success-fn ,error-fn ,_timer)
|
||
cont)
|
||
(head (pop (jsonrpc--scontrol conn)))
|
||
(anxious (cdr head)))
|
||
(cond
|
||
(anxious
|
||
(when (not (equal (car head) id)) ; sanity check
|
||
(error "Internal error: please report this bug"))
|
||
;; If there are "anxious" `jsonrpc-request' continuations
|
||
;; that should already have been run, they should run now.
|
||
;; The main continuation -- if it exists -- should run
|
||
;; before them. This order is important to preserve the
|
||
;; throw to the catch tags in `jsonrpc-request' in
|
||
;; order (bug#67945).
|
||
(cl-flet ((later (f arg) (run-at-time 0 nil f arg)))
|
||
(when cont-id
|
||
(if error (later error-fn error)
|
||
(later success-fn result)))
|
||
(cl-loop
|
||
for (acont ares aerr) in anxious
|
||
for (anx-id _method success-fn error-fn) = acont
|
||
do (jsonrpc--event
|
||
conn 'internal
|
||
:log-text (format "anxious continuation to %s running now" anx-id))
|
||
if aerr do (later error-fn aerr)
|
||
else do (later success-fn ares))))
|
||
(cont-id
|
||
;; Else, just run the normal one, with plain funcall.
|
||
(if error (funcall error-fn error)
|
||
(funcall success-fn result)))
|
||
(t
|
||
;; For clarity. This happens if the `jsonrpc-request' was
|
||
;; canceled
|
||
))))
|
||
|
||
(cl-defun jsonrpc--async-request-1 (connection
|
||
method
|
||
params
|
||
&rest args
|
||
&key success-fn error-fn timeout-fn
|
||
(timeout jsonrpc-default-request-timeout)
|
||
(deferred nil)
|
||
(sync-request nil))
|
||
"Helper for `jsonrpc-request' and `jsonrpc-async-request'.
|
||
|
||
Return a list (ID TIMER). ID is the new request's ID, or nil if
|
||
the request was deferred. TIMER is a timer object set (or nil, if
|
||
TIMEOUT is nil)."
|
||
(pcase-let* ((buf (current-buffer)) (point (point))
|
||
(`(,_ ,timer ,old-id)
|
||
(and deferred (gethash (list deferred buf)
|
||
(jsonrpc--deferred-actions connection))))
|
||
(id (or old-id (cl-incf (jsonrpc--next-request-id connection))))
|
||
(maybe-timer
|
||
(lambda ()
|
||
(when timeout
|
||
(or timer
|
||
(setq
|
||
timer
|
||
(run-with-timer
|
||
timeout nil
|
||
(lambda ()
|
||
(jsonrpc--remove connection id (list deferred buf))
|
||
(jsonrpc--event
|
||
connection 'internal
|
||
:log-text (format "timed-out request '%s'" method)
|
||
:id id)
|
||
(when timeout-fn (funcall timeout-fn))))))))))
|
||
(when deferred
|
||
(if (jsonrpc-connection-ready-p connection deferred)
|
||
;; Server is ready, we jump below and send it immediately.
|
||
(remhash (list deferred buf) (jsonrpc--deferred-actions connection))
|
||
;; Otherwise, save in `jsonrpc--deferred-actions' and exit non-locally
|
||
(unless old-id
|
||
(jsonrpc--event
|
||
connection 'internal
|
||
:log-text (format "deferring request '%s'" method)
|
||
:id id))
|
||
(puthash (list deferred buf)
|
||
(list (lambda ()
|
||
(when (buffer-live-p buf)
|
||
(with-current-buffer buf
|
||
(save-excursion (goto-char point)
|
||
(apply #'jsonrpc--async-request-1
|
||
connection
|
||
method params args)))))
|
||
(funcall maybe-timer) id)
|
||
(jsonrpc--deferred-actions connection))
|
||
(cl-return-from jsonrpc--async-request-1 (list id timer))))
|
||
;; Really send it thru the wire
|
||
;;
|
||
(apply #'jsonrpc-connection-send connection
|
||
:id id
|
||
:method method
|
||
(unless (eq params :jsonrpc-omit) `(:params ,params)))
|
||
;; Setup some control structures
|
||
;;
|
||
(when sync-request
|
||
(push `((:local ,id)) (jsonrpc--scontrol connection)))
|
||
|
||
(jsonrpc--schedule
|
||
connection id method
|
||
(or success-fn
|
||
(lambda (&rest _ignored)
|
||
(jsonrpc--event
|
||
connection 'internal
|
||
:log-text (format "success ignored")
|
||
:id id)))
|
||
(or error-fn
|
||
(jsonrpc-lambda (&key code message &allow-other-keys)
|
||
(jsonrpc--event
|
||
connection 'internal
|
||
:log-text (format "error %s ignored: %s ignored"
|
||
code message)
|
||
:id id)))
|
||
(funcall maybe-timer))
|
||
(list id timer)))
|
||
|
||
(defun jsonrpc--message (format &rest args)
|
||
"Message out with FORMAT with ARGS."
|
||
(message "[jsonrpc] %s" (apply #'format format args)))
|
||
|
||
(defun jsonrpc--debug (server format &rest args)
|
||
"Debug message for SERVER with FORMAT and ARGS."
|
||
(with-current-buffer (jsonrpc-events-buffer server)
|
||
(jsonrpc--log-event
|
||
server 'internal
|
||
:log-text (apply #'format format args)
|
||
:type 'debug)))
|
||
|
||
(defun jsonrpc--warn (format &rest args)
|
||
"Warning message with FORMAT and ARGS."
|
||
(apply #'jsonrpc--message (concat "(warning) " format) args)
|
||
(let ((warning-minimum-level :error))
|
||
(display-warning 'jsonrpc
|
||
(apply #'format format args)
|
||
:warning)))
|
||
|
||
(cl-defun jsonrpc--event (connection
|
||
origin
|
||
&rest plist
|
||
&key _kind _json _message _foreign-message _log-text
|
||
&allow-other-keys)
|
||
(with-current-buffer (jsonrpc-events-buffer connection)
|
||
(run-hook-wrapped 'jsonrpc-event-hook
|
||
(lambda (fn)
|
||
(condition-case oops
|
||
(apply fn connection origin plist)
|
||
(error
|
||
(jsonrpc--message "event hook '%s' errored (%s). Removing it"
|
||
fn oops)
|
||
(remove-hook 'jsonrpc-event-hook fn)))))))
|
||
|
||
(defun jsonrpc--limit-buffer-size (max-size)
|
||
"Limit the current buffer to MAX-SIZE by eating lines at the beginning.
|
||
Do nothing if MAX-SIZE is nil."
|
||
(when max-size
|
||
(while (> (buffer-size) max-size)
|
||
(delete-region
|
||
(point-min)
|
||
(save-excursion
|
||
;; Remove 1/4, so that the cost is O(1) amortized, since each
|
||
;; call to `delete-region' will move the buffer contents twice.
|
||
(goto-char (+ (point-min) (/ (buffer-size) 4)))
|
||
(forward-line)
|
||
(point))))))
|
||
|
||
(defvar jsonrpc-event-hook (list #'jsonrpc--log-event)
|
||
"Hook run when JSON-RPC events are emitted.
|
||
This hooks runs in the events buffer of every `jsonrpc-connection'
|
||
when an event is originated by either endpoint. Each hook function
|
||
is passed the arguments described by the lambda list:
|
||
|
||
(CONNECTION ORIGIN &key JSON KIND MESSAGE FOREIGN-MESSAGE LOG-TEXT
|
||
&allow-other-keys)
|
||
|
||
CONNECTION the `jsonrpc-connection' instance.
|
||
ORIGIN one of the symbols `client' ,`server'.
|
||
JSON the raw JSON string content.
|
||
KIND one of the symbols `request' ,`notification',
|
||
`reply'.
|
||
MESSAGE a plist representing the exchanged message in
|
||
jsonrpc.el's internal format
|
||
FOREIGN-MESSAGE a plist representing the exchanged message in
|
||
the remote endpoint's format.
|
||
LOG-TEXT text used for events of `internal' origin.
|
||
ID id of a message that this event refers to.
|
||
TYPE `error', `debug' or the default `info'.
|
||
|
||
Except for CONNECTION and ORIGIN all other keys are optional.
|
||
Unlisted keys may appear in the plist.
|
||
|
||
Do not use this hook to write JSON-RPC protocols, use other parts
|
||
of the API instead.")
|
||
|
||
(cl-defun jsonrpc--log-event (connection origin
|
||
&key _kind message
|
||
foreign-message log-text json
|
||
type ((:id ref-id))
|
||
&allow-other-keys)
|
||
"Log a JSONRPC-related event. Installed in `jsonrpc-event-hook'."
|
||
(let* ((props (slot-value connection '-events-buffer-config))
|
||
(max (plist-get props :size))
|
||
(format (plist-get props :format)))
|
||
(when (or (null max) (cl-plusp max))
|
||
(cl-destructuring-bind (&key method id error &allow-other-keys) message
|
||
(let* ((inhibit-read-only t)
|
||
(depth (length
|
||
(jsonrpc--scontrol connection)))
|
||
(preamble (format "[jsonrpc] %s[%s]%s "
|
||
(pcase type ('error "E") ('debug "D")
|
||
(_ (pcase origin
|
||
('internal "i")
|
||
(_ "e"))))
|
||
(format-time-string "%H:%M:%S.%3N")
|
||
(if (eq origin 'internal)
|
||
(if ref-id (format " [%s]" ref-id) "")
|
||
(format " %s%s %s%s"
|
||
(make-string (* 2 depth) ? )
|
||
(pcase origin
|
||
('client "-->")
|
||
('server "<--")
|
||
(_ ""))
|
||
(or method "")
|
||
(if id (format "[%s]" id) "")))))
|
||
(msg
|
||
(pcase format
|
||
('full (format "%s%s\n" preamble (or json log-text)))
|
||
('short (format "%s%s\n" preamble (or log-text "")))
|
||
(_
|
||
(format "%s%s" preamble
|
||
(or (and foreign-message
|
||
(let ((lisp-indent-function ;bug#68072
|
||
#'lisp-indent-function))
|
||
(concat "\n" (pp-to-string
|
||
foreign-message))))
|
||
(concat log-text "\n")))))))
|
||
;; XXX: could use `run-at-time' to delay server logs
|
||
;; slightly to play nice with verbose servers' stderr.
|
||
(when error
|
||
(setq msg (propertize msg 'face 'error)))
|
||
(save-excursion
|
||
(goto-char (point-max))
|
||
(insert-before-markers msg))
|
||
(jsonrpc--limit-buffer-size max))))))
|
||
|
||
(defun jsonrpc--forwarding-buffer (name prefix conn)
|
||
"Helper for `jsonrpc-process-connection' helpers.
|
||
Make a stderr buffer named NAME, forwarding lines prefixed by
|
||
PREFIX to CONN's events buffer."
|
||
(with-current-buffer (get-buffer-create name)
|
||
(let ((inhibit-read-only t))
|
||
(fundamental-mode)
|
||
(erase-buffer)
|
||
(buffer-disable-undo)
|
||
(add-hook
|
||
'after-change-functions
|
||
(lambda (beg _end _pre-change-len)
|
||
(let* ((props (slot-value conn '-events-buffer-config))
|
||
(max (plist-get props :size)))
|
||
(unless (eql max 0)
|
||
(cl-loop initially (goto-char beg)
|
||
do (forward-line)
|
||
while (bolp)
|
||
for line = (buffer-substring
|
||
(line-beginning-position 0)
|
||
(line-end-position 0))
|
||
do (with-current-buffer (jsonrpc-events-buffer conn)
|
||
(let ((inhibit-read-only t))
|
||
(save-excursion
|
||
(goto-char (point-max))
|
||
(insert-before-markers
|
||
(propertize (format "%s %s\n" prefix line)
|
||
'face 'shadow)))
|
||
(jsonrpc--limit-buffer-size max)))
|
||
until (eobp)))))
|
||
nil t))
|
||
(current-buffer)))
|
||
|
||
|
||
;;;; More convenience utils
|
||
(cl-defun jsonrpc-autoport-bootstrap (name contact
|
||
&key connect-args)
|
||
"Use CONTACT to start network server, then connect to it.
|
||
|
||
Return function suitable for the :PROCESS initarg of
|
||
`jsonrpc-process-connection' (which see).
|
||
|
||
CONTACT is a list where all the elements are strings except for
|
||
one, which is usuallky the keyword `:autoport'.
|
||
|
||
When the returned function is called it will start a program
|
||
using a command based on CONTACT, where `:autoport' is
|
||
substituted by a locally free network port. Thereafter, a
|
||
network is made to this port.
|
||
|
||
Instead of the keyword `:autoport', a cons cell (:autoport
|
||
FORMAT-FN) is also accepted. In that case FORMAT-FN is passed
|
||
the port number and should return a string used for the
|
||
substitution.
|
||
|
||
The internal processes and control buffers are named after NAME.
|
||
|
||
CONNECT-ARGS are passed as additional arguments to
|
||
`open-network-stream'."
|
||
(lambda (conn)
|
||
(let* ((port-probe (make-network-process :name "jsonrpc-port-probe-dummy"
|
||
:server t
|
||
:host "localhost"
|
||
:service 0))
|
||
(port-number (unwind-protect
|
||
(process-contact port-probe :service)
|
||
(delete-process port-probe)))
|
||
(inferior-buffer (jsonrpc--forwarding-buffer
|
||
(format " *%s inferior output*" name)
|
||
"[inferior]"
|
||
conn))
|
||
(cmd (cl-loop for e in contact
|
||
if (eq e :autoport) collect (format "%s" port-number)
|
||
else if (eq (car-safe e) :autoport)
|
||
collect (funcall (cdr e) port-number)
|
||
else collect e))
|
||
inferior np)
|
||
(unwind-protect
|
||
(progn
|
||
(message "[jsonrpc] Attempting to start `%s'"
|
||
(string-join cmd " "))
|
||
(setq inferior
|
||
(make-process
|
||
:name (format "inferior (%s)" name)
|
||
:buffer inferior-buffer
|
||
:noquery t
|
||
:command cmd))
|
||
(setq np
|
||
(cl-loop
|
||
repeat 10 for i from 0
|
||
do (accept-process-output nil 0.5)
|
||
while (process-live-p inferior)
|
||
do (message
|
||
"[jsonrpc] %sTrying to connect to localhost:%s (attempt %s)"
|
||
(if (zerop i) "Started. " "")
|
||
port-number (1+ i))
|
||
thereis (ignore-errors
|
||
(apply #'open-network-stream
|
||
(format "autostart (%s)" name)
|
||
nil
|
||
"localhost" port-number connect-args))))
|
||
(setf (slot-value conn '-autoport-inferior) inferior)
|
||
np)
|
||
(cond ((and (process-live-p np)
|
||
(process-live-p inferior))
|
||
(message "[jsonrpc] Done, connected to %s!" port-number))
|
||
(t
|
||
(when inferior (delete-process inferior))
|
||
(when np (delete-process np))
|
||
(error "[jsonrpc] Could not start and/or connect")))))))
|
||
|
||
(defun jsonrpc-continuation-count (conn)
|
||
"Number of outstanding continuations for CONN."
|
||
(length (jsonrpc--continuations conn)))
|
||
|
||
(provide 'jsonrpc)
|
||
;;; jsonrpc.el ends here
|