9e24cde227
This will help Eglot and some other extensions connect to network servers that are started with a call to a local program. * lisp/jsonrpc.el (jsonrpc--process-sentinel): Also delete inferior. (jsonrpc-process-connection): Add -autoport-inferior slot. (initialize-instance jsonrpc-process-connection): Check process-creating function arity. Use jsonrpc-forwarding-buffer (jsonrpc-autoport-bootstrap): New helper. (Version): Bump to 1.0.20.
910 lines
38 KiB
EmacsLisp
910 lines
38 KiB
EmacsLisp
;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2018-2023 Free Software Foundation, Inc.
|
||
|
||
;; Author: João Távora <joaotavora@gmail.com>
|
||
;; Keywords: processes, languages, extensions
|
||
;; Version: 1.0.20
|
||
;; 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.")
|
||
(-request-continuations
|
||
:initform (make-hash-table)
|
||
:accessor jsonrpc--request-continuations
|
||
:documentation "A hash table of request ID to continuation lambdas.")
|
||
(-events-buffer
|
||
:initform nil
|
||
:accessor jsonrpc--events-buffer
|
||
:documentation "A buffer pretty-printing the JSONRPC events")
|
||
(-events-buffer-scrollback-size
|
||
:initform nil
|
||
:initarg :events-buffer-scrollback-size
|
||
:accessor jsonrpc--events-buffer-scrollback-size
|
||
:documentation "Max size of events buffer. 0 disables, nil means infinite.")
|
||
(-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.")
|
||
(-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 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.")
|
||
|
||
;;; 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) remote-message))
|
||
|
||
|
||
;;; Convenience
|
||
;;;
|
||
(cl-defmacro jsonrpc-lambda (cl-lambda-list &body body)
|
||
(declare (indent 1) (debug (sexp &rest form)))
|
||
(let ((e (cl-gensym "jsonrpc-lambda-elem")))
|
||
`(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e))))
|
||
|
||
(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)))
|
||
(buffer-disable-undo)
|
||
(setq buffer-read-only t)
|
||
(setf (jsonrpc--events-buffer connection)
|
||
(current-buffer))))))
|
||
|
||
(defun jsonrpc-forget-pending-continuations (connection)
|
||
"Stop waiting for responses from the current JSONRPC CONNECTION."
|
||
(clrhash (jsonrpc--request-continuations connection)))
|
||
|
||
(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 (connection message)
|
||
"Process MESSAGE just received from CONNECTION.
|
||
This function will destructure MESSAGE and call the appropriate
|
||
dispatcher in CONNECTION."
|
||
(cl-destructuring-bind (&key method id error params result _jsonrpc)
|
||
(jsonrpc-convert-from-endpoint connection message)
|
||
(jsonrpc--log-event connection message 'server
|
||
(cond ((and method id) 'request)
|
||
(method 'notification)
|
||
(id 'reply)))
|
||
(let (continuations)
|
||
(setf (jsonrpc-last-error connection) error)
|
||
(cond
|
||
(;; A remote request
|
||
(and method id)
|
||
(let* ((debug-on-error (and debug-on-error
|
||
(not jsonrpc-inhibit-debug-on-error)))
|
||
(reply
|
||
(condition-case-unless-debug _ignore
|
||
(condition-case oops
|
||
`(:result ,(funcall (jsonrpc--request-dispatcher connection)
|
||
connection (intern method) params))
|
||
(jsonrpc-error
|
||
`(:error
|
||
(:code
|
||
,(or (alist-get 'jsonrpc-error-code (cdr oops)) -32603)
|
||
:message ,(or (alist-get 'jsonrpc-error-message
|
||
(cdr oops))
|
||
"Internal error")))))
|
||
(error
|
||
'(:error (:code -32603 :message "Internal error"))))))
|
||
(apply #'jsonrpc--reply connection id method reply)))
|
||
(;; A remote notification
|
||
method
|
||
(funcall (jsonrpc--notification-dispatcher connection)
|
||
connection (intern method) params))
|
||
(;; A remote response
|
||
(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))))
|
||
(jsonrpc--call-deferred connection))))
|
||
|
||
|
||
;;; 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.
|
||
|
||
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.
|
||
|
||
Returns nil."
|
||
(apply #'jsonrpc--async-request-1 connection method params args)
|
||
nil)
|
||
|
||
(cl-defun jsonrpc-request (connection
|
||
method params &key
|
||
deferred timeout
|
||
cancel-on-input
|
||
cancel-on-input-retval)
|
||
"Make a request to CONNECTION, wait for a reply.
|
||
Like `jsonrpc-async-request' for CONNECTION, METHOD and PARAMS,
|
||
but synchronous.
|
||
|
||
Except in the case of a non-nil CANCEL-ON-INPUT (explained
|
||
below), this function doesn't exit until anything interesting
|
||
happens (success reply, error reply, or timeout). Furthermore,
|
||
it only exits locally (returning the JSONRPC result object) if
|
||
the request is successful, otherwise it exits non-locally with an
|
||
error of type `jsonrpc-error'.
|
||
|
||
DEFERRED and TIMEOUT as in `jsonrpc-async-request', which see.
|
||
|
||
If CANCEL-ON-INPUT is non-nil and the user inputs something while
|
||
the function is waiting, then it exits immediately, returning
|
||
CANCEL-ON-INPUT-RETVAL. Any future replies (normal or error) are
|
||
ignored."
|
||
(let* ((tag (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
|
||
:success-fn (lambda (result)
|
||
(unless canceled
|
||
(throw tag `(done ,result))))
|
||
:error-fn
|
||
(jsonrpc-lambda
|
||
(&key code message data)
|
||
(unless canceled
|
||
(throw tag `(error (jsonrpc-error-code . ,code)
|
||
(jsonrpc-error-message . ,message)
|
||
(jsonrpc-error-data . ,data)))))
|
||
:timeout-fn
|
||
(lambda ()
|
||
(unless canceled
|
||
(throw tag '(error (jsonrpc-error-message . "Timed out")))))
|
||
`(,@(when deferred `(:deferred ,deferred))
|
||
,@(when timeout `(:timeout ,timeout)))))
|
||
(cond (cancel-on-input
|
||
(unwind-protect
|
||
(let ((inhibit-quit t)) (while (sit-for 30)))
|
||
(setq canceled t))
|
||
`(canceled ,cancel-on-input-retval))
|
||
(t (while t (accept-process-output nil 30)))))
|
||
;; In normal operation, cancellation is handled by the
|
||
;; timeout function and response filter, but we still have
|
||
;; to protect against user-quit (C-g) or the
|
||
;; `cancel-on-input' case.
|
||
(pcase-let* ((`(,id ,timer) id-and-timer))
|
||
(remhash id (jsonrpc--request-continuations connection))
|
||
(remhash (list deferred (current-buffer))
|
||
(jsonrpc--deferred-actions connection))
|
||
(when timer (cancel-timer timer))))))
|
||
(when (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."
|
||
(jsonrpc-connection-send connection
|
||
:method method
|
||
:params params))
|
||
|
||
(define-obsolete-variable-alias 'jrpc-default-request-timeout
|
||
'jsonrpc-default-request-timeout "28.1")
|
||
|
||
(defconst jsonrpc-default-request-timeout 10
|
||
"Time in seconds before timing out a JSONRPC request.")
|
||
|
||
|
||
;;; 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 ((conn jsonrpc-process-connection) slots)
|
||
(cl-call-next-method)
|
||
(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)
|
||
(with-current-buffer (process-buffer proc)
|
||
(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
|
||
(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* ((subtype (cond ((or result-supplied-p error) 'reply)
|
||
(id 'request)
|
||
(method 'notification)))
|
||
(converted (jsonrpc-convert-to-endpoint connection args subtype))
|
||
(json (jsonrpc--json-encode converted))
|
||
(headers
|
||
`(("Content-Length" . ,(format "%d" (string-bytes json)))
|
||
;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8")
|
||
)))
|
||
(process-send-string
|
||
(jsonrpc--process connection)
|
||
(cl-loop for (header . value) in headers
|
||
concat (concat header ": " value "\r\n") into header-section
|
||
finally return (format "%s\r\n%s" header-section json)))
|
||
(jsonrpc--log-event connection converted 'client subtype)))
|
||
|
||
(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."
|
||
(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)
|
||
do
|
||
(delete-process proc)
|
||
(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 "json" ())
|
||
(lambda ()
|
||
(let ((json-object-type 'plist))
|
||
(json-read))))
|
||
"Read JSON object in buffer, 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--debug connection `(:maybe-run-deferred
|
||
,(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 `(:message "Connection state changed" :change ,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
|
||
(maphash (lambda (_id triplet)
|
||
(pcase-let ((`(,_success ,_error ,timeout) triplet))
|
||
(when timeout (cancel-timer timeout))))
|
||
(jsonrpc--request-continuations connection))
|
||
(process-put proc 'jsonrpc-sentinel-cleanup-started t)
|
||
(unwind-protect
|
||
;; Call all outstanding error handlers
|
||
(maphash (lambda (_id triplet)
|
||
(pcase-let ((`(,_success ,error ,_timeout) triplet))
|
||
(funcall error '(:code -1 :message "Server died"))))
|
||
(jsonrpc--request-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)))))
|
||
|
||
(cl-defun jsonrpc--process-filter (proc string)
|
||
"Called when new data STRING has arrived for PROC."
|
||
(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
|
||
"\\(?:.*: .*\r\n\\)*Content-Length: \
|
||
*\\([[:digit:]]+\\)\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
|
||
(process-put proc 'jsonrpc-mqueue
|
||
(nconc (process-get proc
|
||
'jsonrpc-mqueue)
|
||
(list message)))))
|
||
(goto-char message-end)
|
||
(let ((inhibit-read-only t))
|
||
(delete-region (point-min) (point)))
|
||
(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
|
||
for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg
|
||
do (run-at-time 0 nil
|
||
(lambda (m) (with-temp-buffer
|
||
(jsonrpc-connection-receive conn m)))
|
||
msg)))))))
|
||
|
||
(cl-defun jsonrpc--async-request-1 (connection
|
||
method
|
||
params
|
||
&rest args
|
||
&key success-fn error-fn timeout-fn
|
||
(timeout jsonrpc-default-request-timeout)
|
||
(deferred nil))
|
||
"Does actual work for `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))))
|
||
(make-timer
|
||
(lambda ( )
|
||
(when timeout
|
||
(run-with-timer
|
||
timeout nil
|
||
(lambda ()
|
||
(remhash id (jsonrpc--request-continuations connection))
|
||
(remhash (list deferred buf)
|
||
(jsonrpc--deferred-actions connection))
|
||
(if timeout-fn (funcall timeout-fn)
|
||
(jsonrpc--debug
|
||
connection `(:timed-out ,method :id ,id
|
||
:params ,params)))))))))
|
||
(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--debug connection `(:deferring ,method :id ,id :params
|
||
,params)))
|
||
(puthash (list deferred buf)
|
||
(list (lambda ()
|
||
(when (buffer-live-p buf)
|
||
(with-current-buffer buf
|
||
(save-excursion (goto-char point)
|
||
(apply #'jsonrpc-async-request
|
||
connection
|
||
method params args)))))
|
||
(or timer (setq timer (funcall make-timer))) id)
|
||
(jsonrpc--deferred-actions connection))
|
||
(cl-return-from jsonrpc--async-request-1 (list id timer))))
|
||
;; Really send it
|
||
;;
|
||
(jsonrpc-connection-send connection
|
||
:id id
|
||
:method method
|
||
:params params)
|
||
(puthash id
|
||
(list (or success-fn
|
||
(lambda (&rest _ignored)
|
||
(jsonrpc--debug
|
||
connection (list :message "success ignored"
|
||
:id id))))
|
||
(or error-fn
|
||
(jsonrpc-lambda (&key code message &allow-other-keys)
|
||
(jsonrpc--debug
|
||
connection (list
|
||
:message
|
||
(format "error ignored, status set (%s)"
|
||
message)
|
||
:id id :error code))))
|
||
(setq timer (funcall make-timer)))
|
||
(jsonrpc--request-continuations connection))
|
||
(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."
|
||
(jsonrpc--log-event
|
||
server (if (stringp format)
|
||
`(:message ,(apply #'format format args))
|
||
format)))
|
||
|
||
(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)))
|
||
|
||
(defun jsonrpc--log-event (connection message &optional origin subtype)
|
||
"Log a JSONRPC-related event.
|
||
CONNECTION is the current connection. MESSAGE is a JSON-like
|
||
plist. ORIGIN is a symbol saying where event originated.
|
||
SUBTYPE tells more about the event."
|
||
(let ((max (jsonrpc--events-buffer-scrollback-size connection)))
|
||
(when (or (null max) (cl-plusp max))
|
||
(with-current-buffer (jsonrpc-events-buffer connection)
|
||
(cl-destructuring-bind (&key _method id error &allow-other-keys) message
|
||
(let* ((inhibit-read-only t)
|
||
(type
|
||
(concat (format "%s" (or origin 'internal))
|
||
(if origin (format "-%s" (or subtype 'message))))))
|
||
(goto-char (point-max))
|
||
(prog1
|
||
(let ((msg (format "[%s]%s%s %s:\n%s"
|
||
type
|
||
(if id (format " (id:%s)" id) "")
|
||
(if error " ERROR" "")
|
||
(current-time-string)
|
||
(pp-to-string message))))
|
||
(when error
|
||
(setq msg (propertize msg 'face 'error)))
|
||
(insert-before-markers msg))
|
||
;; Trim the buffer if it's too large
|
||
(when max
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(while (> (buffer-size) max)
|
||
(delete-region (point) (progn (forward-line 1)
|
||
(forward-sexp 1)
|
||
(forward-line 2)
|
||
(point)))))))))))))
|
||
|
||
(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)
|
||
(cl-loop initially (goto-char beg)
|
||
do (forward-line)
|
||
when (bolp)
|
||
for line = (buffer-substring
|
||
(line-beginning-position 0)
|
||
(line-end-position 0))
|
||
do (with-current-buffer (jsonrpc-events-buffer conn)
|
||
(goto-char (point-max))
|
||
(let ((inhibit-read-only t))
|
||
(insert (format "%s %s\n" prefix line))))
|
||
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")))))))
|
||
|
||
|
||
(provide 'jsonrpc)
|
||
;;; jsonrpc.el ends here
|