jsonrpc.el (50751B)
1 ;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2018-2024 Free Software Foundation, Inc. 4 5 ;; Author: João Távora <joaotavora@gmail.com> 6 ;; Keywords: processes, languages, extensions 7 ;; Version: 1.0.25 8 ;; Package-Requires: ((emacs "25.2")) 9 10 ;; This is a GNU ELPA :core package. Avoid functionality that is not 11 ;; compatible with the version of Emacs recorded above. 12 13 ;; This file is part of GNU Emacs. 14 15 ;; GNU Emacs is free software: you can redistribute it and/or modify 16 ;; it under the terms of the GNU General Public License as published by 17 ;; the Free Software Foundation, either version 3 of the License, or 18 ;; (at your option) any later version. 19 20 ;; GNU Emacs is distributed in the hope that it will be useful, 21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 23 ;; GNU General Public License for more details. 24 25 ;; You should have received a copy of the GNU General Public License 26 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 27 28 ;;; Commentary: 29 30 ;; This library implements the JSONRPC 2.0 specification as described 31 ;; in https://www.jsonrpc.org/. As the name suggests, JSONRPC is a 32 ;; generic Remote Procedure Call protocol designed around JSON 33 ;; objects. To learn how to write JSONRPC programs with this library, 34 ;; see Info node `(elisp)JSONRPC'." 35 ;; 36 ;; This library was originally extracted from eglot.el, an Emacs LSP 37 ;; client, which you should see for an example usage. 38 ;; 39 ;;; Code: 40 41 (require 'cl-lib) 42 (require 'eieio) 43 (eval-when-compile (require 'subr-x)) 44 (require 'warnings) 45 (require 'pcase) 46 47 48 ;;; Public API 49 ;;; 50 51 (defclass jsonrpc-connection () 52 ((name 53 :accessor jsonrpc-name 54 :initform "anonymous" 55 :initarg :name 56 :documentation "A name for the connection") 57 (-request-dispatcher 58 :accessor jsonrpc--request-dispatcher 59 :initform #'ignore 60 :initarg :request-dispatcher 61 :documentation "Dispatcher for remotely invoked requests.") 62 (-notification-dispatcher 63 :accessor jsonrpc--notification-dispatcher 64 :initform #'ignore 65 :initarg :notification-dispatcher 66 :documentation "Dispatcher for remotely invoked notifications.") 67 (last-error 68 :initform nil 69 :accessor jsonrpc-last-error 70 :documentation "Last JSONRPC error message received from endpoint.") 71 (-continuations 72 :initform nil 73 :accessor jsonrpc--continuations 74 :documentation "An alist of request IDs to continuation specs.") 75 (-events-buffer 76 :initform nil 77 :accessor jsonrpc--events-buffer 78 :documentation "A buffer pretty-printing the JSONRPC events") 79 (-events-buffer-config 80 :initform '(:size nil :format full) 81 :initarg :events-buffer-config 82 :documentation "Plist configuring the events buffer functions.") 83 (-deferred-actions 84 :initform (make-hash-table :test #'equal) 85 :accessor jsonrpc--deferred-actions 86 :documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\ 87 a saved DEFERRED `async-request' from BUF, to be sent not later\ 88 than TIMER as ID.") 89 (-sync-request-alist ; bug#67945 90 :initform nil 91 :accessor jsonrpc--sync-request-alist 92 :documentation "List of ((ID [ANXIOUS...])) where ID refers \ 93 to a sync `jsonrpc-request' and each ANXIOUS to another completed\ 94 request that is higher up in the stack but couldn't run.") 95 (-next-request-id 96 :initform 0 97 :accessor jsonrpc--next-request-id 98 :documentation "Next number used for a request")) 99 :documentation "Base class representing a JSONRPC connection. 100 The following keyword argument initargs are accepted: 101 102 :NAME (mandatory), a string naming the connection 103 104 :REQUEST-DISPATCHER (optional), a function of three 105 arguments (CONN METHOD PARAMS) for handling JSONRPC requests. 106 CONN is a `jsonrpc-connection' object, method is a symbol, and 107 PARAMS is a plist representing a JSON object. The function is 108 expected to return a JSONRPC result, a plist of (:result 109 RESULT) or signal an error of type `jsonrpc-error'. 110 111 :NOTIFICATION-DISPATCHER (optional), a function of three 112 arguments (CONN METHOD PARAMS) for handling JSONRPC 113 notifications. CONN, METHOD and PARAMS are the same as in 114 :REQUEST-DISPATCHER. 115 116 :EVENTS-BUFFER-CONFIG is a plist. Its `:size' stipulates the 117 size of the log buffer (0 disables, nil means infinite). The 118 `:format' property is a symbol for choosing the log entry format.") 119 120 (cl-defmethod initialize-instance :after 121 ((c jsonrpc-connection) ((&key (events-buffer-scrollback-size 122 nil 123 e-b-s-s-supplied-p) 124 &allow-other-keys) 125 t)) 126 (when e-b-s-s-supplied-p 127 (warn 128 "`:events-buffer-scrollback-size' deprecated. Use `events-buffer-config'.") 129 (with-slots ((plist -events-buffer-config)) c 130 (setf plist (copy-sequence plist) 131 plist (plist-put plist :size events-buffer-scrollback-size))))) 132 133 (cl-defmethod slot-missing ((_c jsonrpc-connection) 134 (_n (eql :events-buffer-scrollback-size)) 135 (_op (eql oset)) 136 _) 137 ;; Yuck! But this just coerces EIEIO to backward-compatibly accept 138 ;; the :e-b-s-s initarg that is no longer associated with a slot 139 ;; #pineForCLOS.. 140 ) 141 142 ;;; API mandatory 143 (cl-defgeneric jsonrpc-connection-send (conn &key id method params result error) 144 "Send a JSONRPC message to connection CONN. 145 ID, METHOD, PARAMS, RESULT and ERROR.") 146 147 ;;; API optional 148 (cl-defgeneric jsonrpc-shutdown (conn) 149 "Shutdown the JSONRPC connection CONN.") 150 151 ;;; API optional 152 (cl-defgeneric jsonrpc-running-p (conn) 153 "Tell if the JSONRPC connection CONN is still running.") 154 155 ;;; API optional 156 (cl-defgeneric jsonrpc-connection-ready-p (connection what) 157 "Tell if CONNECTION is ready for WHAT in current buffer. 158 If it isn't, a request which was passed a value to the 159 `:deferred' keyword argument will be deferred to the future. 160 WHAT is whatever was passed the as the value to that argument. 161 162 By default, all connections are ready for sending all requests 163 immediately." 164 (:method (_s _what) ;; by default all connections are ready 165 t)) 166 167 ;;; API optional 168 (cl-defgeneric jsonrpc-convert-to-endpoint (connection message subtype) 169 "Convert MESSAGE to JSONRPCesque message accepted by endpoint. 170 MESSAGE is a plist, jsonrpc.el's internal representation of a 171 JSONRPC message. SUBTYPE is one of `request', `reply' or 172 `notification'. 173 174 Return a plist to be serialized to JSON with `json-serialize' and 175 transmitted to endpoint." 176 ;; TODO: describe representations and serialization in manual and 177 ;; link here. 178 (:method (_s message subtype) 179 `(:jsonrpc "2.0" 180 ,@(if (eq subtype 'reply) 181 ;; true JSONRPC doesn't have `method' 182 ;; fields in responses. 183 (cl-loop for (k v) on message by #'cddr 184 unless (eq k :method) 185 collect k and collect v) 186 message)))) 187 188 ;;; API optional 189 (cl-defgeneric jsonrpc-convert-from-endpoint (connection remote-message) 190 "Convert JSONRPC-esque REMOTE-MESSAGE to a plist. 191 REMOTE-MESSAGE is a plist read with `json-parse'. 192 193 Return a plist of jsonrpc.el's internal representation of a 194 JSONRPC message." 195 ;; TODO: describe representations and serialization in manual and 196 ;; link here. 197 (:method (_s remote-message) 198 (cl-loop for (k v) on remote-message by #'cddr 199 unless (eq k :jsonrpc-json) 200 collect k and collect v))) 201 202 203 ;;; Convenience 204 ;;; 205 (cl-defmacro jsonrpc-lambda (cl-lambda-list &body body) 206 (declare (indent 1) (debug (sexp &rest form))) 207 (let ((e (cl-gensym "jsonrpc-lambda-elem"))) 208 `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e)))) 209 210 (defun jsonrpc-events-buffer (connection) 211 "Get or create JSONRPC events buffer for CONNECTION." 212 (let ((probe (jsonrpc--events-buffer connection))) 213 (if (buffer-live-p probe) 214 probe 215 (with-current-buffer 216 (get-buffer-create (format "*%s events*" (jsonrpc-name connection))) 217 (buffer-disable-undo) 218 (setq buffer-read-only t) 219 (setf (jsonrpc--events-buffer connection) 220 (current-buffer)))))) 221 222 (defun jsonrpc-forget-pending-continuations (connection) 223 "Stop waiting for responses from the current JSONRPC CONNECTION." 224 (setf (jsonrpc--continuations connection) nil)) 225 226 (defvar jsonrpc-inhibit-debug-on-error nil 227 "Inhibit `debug-on-error' when answering requests. 228 Some extensions, notably ert.el, set `debug-on-error' to non-nil, 229 which makes it hard to test the behavior of catching the Elisp 230 error and replying to the endpoint with an JSONRPC-error. This 231 variable can be set around calls like `jsonrpc-request' to 232 circumvent that.") 233 234 (defun jsonrpc-connection-receive (conn foreign-message) 235 "Process FOREIGN-MESSAGE just received from CONN. 236 This function will destructure MESSAGE and call the appropriate 237 dispatcher in CONN." 238 (cl-destructuring-bind (&rest whole &key method id error params result _jsonrpc) 239 (jsonrpc-convert-from-endpoint conn foreign-message) 240 (unwind-protect 241 (let* ((log-plist (list :json (plist-get foreign-message :jsonrpc-json) 242 :kind (cond ((and method id) 'request) 243 (method 'notification) 244 (id 'reply)) 245 :message whole 246 :foreign-message foreign-message)) 247 (response-p (and (null method) id)) 248 (cont (and response-p (jsonrpc--remove conn id)))) 249 (cl-remf foreign-message :jsonrpc-json) 250 ;; Do this pre-processing of the response so we can always 251 ;; log richer information _before_ any non-local calls 252 ;; further ahead. Putting the `jsonrpc--event' as 253 ;; an unwind-form would make us log after the fact. 254 (when cont 255 (pcase-let ((`(,_ ,method ,_ ,_ ,_) cont)) 256 (if (keywordp method) 257 (setq method (substring (symbol-name method) 1))) 258 ;; TODO: also set the depth 259 (setq whole (plist-put whole :method method)))) 260 261 ;; Do the logging 262 (apply #'jsonrpc--event conn 'server log-plist) 263 (with-slots (last-error 264 (rdispatcher -request-dispatcher) 265 (ndispatcher -notification-dispatcher) 266 (sr-alist -sync-request-alist)) 267 conn 268 (setf last-error error) 269 (cond 270 (;; A remote response whose request has been canceled 271 ;; (i.e. timeout or C-g) 272 ;; 273 (and response-p (null cont)) 274 (jsonrpc--event 275 conn 'internal 276 :log-text 277 (format "Response to request %s which has been canceled" 278 id) 279 :id id) 280 ;; TODO: food for thought: this seems to be also where 281 ;; notifying the server of the cancellation would come 282 ;; in. 283 ) 284 (;; A remote response that can't run yet (bug#67945) 285 (and response-p 286 (and sr-alist (not (eq id (caar sr-alist))))) 287 (jsonrpc--event 288 conn 'internal 289 :log-text 290 (format "anxious continuation to %s can't run, held up by %s" 291 id 292 (mapcar #'car sr-alist))) 293 (push (cons cont (list result error)) 294 (cdr (car sr-alist)))) 295 (;; A remote response that can continue now 296 response-p 297 (jsonrpc--continue conn id cont result error)) 298 (;; A remote request 299 (and method id) 300 (let* ((debug-on-error (and debug-on-error 301 (not jsonrpc-inhibit-debug-on-error))) 302 (reply 303 (condition-case-unless-debug _ignore 304 (condition-case oops 305 `(:result ,(funcall rdispatcher conn (intern method) 306 params)) 307 (jsonrpc-error 308 `(:error 309 (:code 310 ,(or (alist-get 'jsonrpc-error-code (cdr oops)) 311 -32603) 312 :message ,(or (alist-get 'jsonrpc-error-message 313 (cdr oops)) 314 "Internal error"))))) 315 (error 316 '(:error (:code -32603 :message "Internal error")))))) 317 (apply #'jsonrpc--reply conn id method reply))) 318 (;; A remote notification 319 method 320 (funcall ndispatcher conn (intern method) params)) 321 (t 322 (jsonrpc--event conn 'internal 323 :log-text "Malformed message" ))))) 324 (jsonrpc--call-deferred conn)))) 325 326 327 ;;; Contacting the remote endpoint 328 ;;; 329 (defun jsonrpc-error (&rest args) 330 "Error out with FORMAT and ARGS. 331 If invoked inside a dispatcher function, this function is suitable 332 for replying to the remote endpoint with an error message. 333 334 ARGS can be of the form (FORMAT-STRING . MOREARGS) for replying 335 with a -32603 error code and a message formed by formatting 336 FORMAT-STRING with MOREARGS. 337 338 Alternatively ARGS can be plist representing a JSONRPC error 339 object, using the keywords `:code', `:message' and `:data'." 340 (if (stringp (car args)) 341 (let ((msg 342 (apply #'format-message (car args) (cdr args)))) 343 (signal 'jsonrpc-error 344 `(,msg 345 (jsonrpc-error-code . -32603) 346 (jsonrpc-error-message . ,msg)))) 347 (cl-destructuring-bind (&key code message data) args 348 (signal 'jsonrpc-error 349 `("[jsonrpc] error " 350 (jsonrpc-error-code . ,code) 351 (jsonrpc-error-message . ,message) 352 (jsonrpc-error-data . ,data)))))) 353 354 (cl-defun jsonrpc-async-request (connection 355 method 356 params 357 &rest args 358 &key _success-fn _error-fn 359 _timeout-fn 360 _timeout _deferred) 361 "Make a request to CONNECTION, expecting a reply, return immediately. 362 The JSONRPC request is formed by METHOD, a symbol, and PARAMS a 363 JSON object. 364 365 The caller can expect SUCCESS-FN or ERROR-FN to be called with a 366 JSONRPC `:result' or `:error' object, respectively. If this 367 doesn't happen after TIMEOUT seconds (defaults to 368 `jrpc-default-request-timeout'), the caller can expect TIMEOUT-FN 369 to be called with no arguments. The default values of SUCCESS-FN, 370 ERROR-FN and TIMEOUT-FN simply log the events into 371 `jsonrpc-events-buffer'. 372 373 If DEFERRED is non-nil, maybe defer the request to a future time 374 when the server is thought to be ready according to 375 `jsonrpc-connection-ready-p' (which see). The request might 376 never be sent at all, in case it is overridden in the meantime by 377 a new request with identical DEFERRED and for the same buffer. 378 However, in that situation, the original timeout is kept. 379 380 Returns nil." 381 (apply #'jsonrpc--async-request-1 connection method params args) 382 nil) 383 384 (cl-defun jsonrpc-request (connection 385 method params &key 386 deferred timeout 387 cancel-on-input 388 cancel-on-input-retval) 389 "Make a request to CONNECTION, wait for a reply. 390 Like `jsonrpc-async-request' for CONNECTION, METHOD and PARAMS, 391 but synchronous. 392 393 Except in the case of a non-nil CANCEL-ON-INPUT (explained 394 below), this function doesn't exit until anything interesting 395 happens (success reply, error reply, or timeout). Furthermore, 396 it only exits locally (returning the JSONRPC result object) if 397 the request is successful, otherwise it exits non-locally with an 398 error of type `jsonrpc-error'. 399 400 DEFERRED and TIMEOUT as in `jsonrpc-async-request', which see. 401 402 If CANCEL-ON-INPUT is non-nil and the user inputs something while 403 the function is waiting, then it exits immediately, returning 404 CANCEL-ON-INPUT-RETVAL. Any future replies (normal or error) are 405 ignored." 406 (let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer 407 canceled 408 (throw-on-input nil) 409 (retval 410 (unwind-protect 411 (catch tag 412 (setq 413 id-and-timer 414 (apply 415 #'jsonrpc--async-request-1 416 connection method params 417 :sync-request t 418 :success-fn (lambda (result) 419 (unless canceled 420 (throw tag `(done ,result)))) 421 :error-fn 422 (jsonrpc-lambda 423 (&key code message data) 424 (unless canceled 425 (throw tag `(error (jsonrpc-error-code . ,code) 426 (jsonrpc-error-message . ,message) 427 (jsonrpc-error-data . ,data))))) 428 :timeout-fn 429 (lambda () 430 (unless canceled 431 (throw tag '(error (jsonrpc-error-message . "Timed out"))))) 432 `(,@(when deferred `(:deferred ,deferred)) 433 ,@(when timeout `(:timeout ,timeout))))) 434 (cond (cancel-on-input 435 (unwind-protect 436 (let ((inhibit-quit t)) (while (sit-for 30))) 437 (setq canceled t)) 438 `(canceled ,cancel-on-input-retval)) 439 (t (while t (accept-process-output nil 30))))) 440 ;; In normal operation, continuations for error/success is 441 ;; handled by `jsonrpc--continue'. Timeouts also remove 442 ;; the continuation... 443 (pcase-let* ((`(,id ,_) id-and-timer)) 444 ;; ...but we still have to guard against exist explicit 445 ;; user-quit (C-g) or the `cancel-on-input' case, so 446 ;; discard the continuation. 447 (jsonrpc--remove connection id (list deferred (current-buffer))) 448 ;; ...finally, whatever may have happened to this sync 449 ;; request, it might have been holding up any outer 450 ;; "anxious" continuations. The following ensures we 451 ;; cll them. 452 (jsonrpc--continue connection id))))) 453 (when (eq 'error (car retval)) 454 (signal 'jsonrpc-error 455 (cons 456 (format "request id=%s failed:" (car id-and-timer)) 457 (cdr retval)))) 458 (cadr retval))) 459 460 (cl-defun jsonrpc-notify (connection method params) 461 "Notify CONNECTION of something, don't expect a reply." 462 (jsonrpc-connection-send connection 463 :method method 464 :params params)) 465 466 (define-obsolete-variable-alias 'jrpc-default-request-timeout 467 'jsonrpc-default-request-timeout "28.1") 468 469 (defconst jsonrpc-default-request-timeout 10 470 "Time in seconds before timing out a JSONRPC request.") 471 472 473 ;;; Specific to `jsonrpc-process-connection' 474 ;;; 475 476 (defclass jsonrpc-process-connection (jsonrpc-connection) 477 ((-process 478 :initarg :process :accessor jsonrpc--process 479 :documentation "Process object wrapped by the this connection.") 480 (-expected-bytes 481 :initform nil 482 :accessor jsonrpc--expected-bytes 483 :documentation "How many bytes declared by server.") 484 (-on-shutdown 485 :accessor jsonrpc--on-shutdown 486 :initform #'ignore 487 :initarg :on-shutdown 488 :documentation "Function run when the process dies.") 489 (-autoport-inferior 490 :initform nil 491 :documentation "Used by `jsonrpc-autoport-bootstrap'.")) 492 :documentation "A JSONRPC connection over an Emacs process. 493 The following initargs are accepted: 494 495 :PROCESS (mandatory), a live running Emacs process object or a 496 function producing one such object. If a function, it is passed 497 the `jsonrpc-process-connection' object. The process represents 498 either a pipe connection to locally running process or a stream 499 connection to a network host. The remote endpoint is expected to 500 understand JSONRPC messages with basic HTTP-style enveloping 501 headers such as \"Content-Length:\". 502 503 :ON-SHUTDOWN (optional), a function of one argument, the 504 connection object, called when the process dies.") 505 506 (cl-defmethod initialize-instance :after ((conn jsonrpc-process-connection) slots) 507 (cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots 508 ;; FIXME: notice the undocumented bad coupling in the stderr 509 ;; buffer name, it must be named exactly like this we expect when 510 ;; calling `make-process'. If there were a `set-process-stderr' 511 ;; like there is `set-process-buffer' we wouldn't need this and 512 ;; could use a pipe with a process filter instead of 513 ;; `after-change-functions'. Alternatively, we need a new initarg 514 ;; (but maybe not a slot). 515 (let* ((stderr-buffer-name (format "*%s stderr*" name)) 516 (stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name "[stderr] " conn)) 517 (hidden-name (concat " " stderr-buffer-name))) 518 ;; If we are correctly coupled to the client, the process now 519 ;; created should pick up the `stderr-buffer' just created, which 520 ;; we immediately rename 521 (setq proc (if (functionp proc) 522 (if (zerop (cdr (func-arity proc))) 523 (funcall proc) 524 (funcall proc conn)) 525 proc)) 526 (with-current-buffer stderr-buffer 527 (ignore-errors (kill-buffer hidden-name)) 528 (rename-buffer hidden-name) 529 (setq buffer-read-only t)) 530 (process-put proc 'jsonrpc-stderr stderr-buffer)) 531 (setf (jsonrpc--process conn) proc) 532 (set-process-buffer proc (get-buffer-create (format " *%s output*" name))) 533 (set-process-filter proc #'jsonrpc--process-filter) 534 (set-process-sentinel proc #'jsonrpc--process-sentinel) 535 (with-current-buffer (process-buffer proc) 536 (buffer-disable-undo) 537 (set-marker (process-mark proc) (point-min)) 538 (let ((inhibit-read-only t)) 539 (erase-buffer)) 540 (setq buffer-read-only t)) 541 (process-put proc 'jsonrpc-connection conn))) 542 543 (cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection) 544 &rest args 545 &key 546 id 547 method 548 _params 549 (_result nil result-supplied-p) 550 error 551 _partial) 552 "Send MESSAGE, a JSON object, to CONNECTION." 553 (when method 554 ;; sanitize method into a string 555 (setq args 556 (plist-put args :method 557 (cond ((keywordp method) (substring (symbol-name method) 1)) 558 ((symbolp method) (symbol-name method)) 559 ((stringp method) method) 560 (t (error "[jsonrpc] invalid method %s" method)))))) 561 (let* ((kind (cond ((or result-supplied-p error) 'reply) 562 (id 'request) 563 (method 'notification))) 564 (converted (jsonrpc-convert-to-endpoint connection args kind)) 565 (json (jsonrpc--json-encode converted)) 566 (headers 567 `(("Content-Length" . ,(format "%d" (string-bytes json))) 568 ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8") 569 ))) 570 (process-send-string 571 (jsonrpc--process connection) 572 (cl-loop for (header . value) in headers 573 concat (concat header ": " value "\r\n") into header-section 574 finally return (format "%s\r\n%s" header-section json))) 575 (jsonrpc--event 576 connection 577 'client 578 :json json 579 :kind kind 580 :message args 581 :foreign-message converted))) 582 583 (defun jsonrpc-process-type (conn) 584 "Return the `process-type' of JSONRPC connection CONN." 585 (process-type (jsonrpc--process conn))) 586 587 (cl-defmethod jsonrpc-running-p ((conn jsonrpc-process-connection)) 588 "Return non-nil if JSONRPC connection CONN is running." 589 (process-live-p (jsonrpc--process conn))) 590 591 (cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection) 592 &optional cleanup) 593 "Wait for JSONRPC connection CONN to shutdown. 594 With optional CLEANUP, kill any associated buffers." 595 (unwind-protect 596 (cl-loop 597 with proc = (jsonrpc--process conn) for i from 0 598 while (not (process-get proc 'jsonrpc-sentinel-cleanup-started)) 599 unless (zerop i) do 600 (jsonrpc--warn "Sentinel for %s still hasn't run, deleting it!" proc) 601 do 602 (delete-process proc) 603 (accept-process-output nil 0.1)) 604 (when cleanup 605 (kill-buffer (process-buffer (jsonrpc--process conn))) 606 (kill-buffer (jsonrpc-stderr-buffer conn))))) 607 608 (defun jsonrpc-stderr-buffer (conn) 609 "Get CONN's standard error buffer, if any." 610 (process-get (jsonrpc--process conn) 'jsonrpc-stderr)) 611 612 613 ;;; Private stuff 614 ;;; 615 (define-error 'jsonrpc-error "jsonrpc-error") 616 617 (defalias 'jsonrpc--json-read 618 (if (fboundp 'json-parse-buffer) 619 (lambda () 620 (json-parse-buffer :object-type 'plist 621 :null-object nil 622 :false-object :json-false)) 623 (require 'json) 624 (defvar json-object-type) 625 (declare-function json-read "json" ()) 626 (lambda () 627 (let ((json-object-type 'plist)) 628 (json-read)))) 629 "Read JSON object in buffer, move point to end of buffer.") 630 631 (defalias 'jsonrpc--json-encode 632 (if (fboundp 'json-serialize) 633 (lambda (object) 634 (json-serialize object 635 :false-object :json-false 636 :null-object nil)) 637 (require 'json) 638 (defvar json-false) 639 (defvar json-null) 640 (declare-function json-encode "json" (object)) 641 (lambda (object) 642 (let ((json-false :json-false) 643 (json-null nil)) 644 (json-encode object)))) 645 "Encode OBJECT into a JSON string.") 646 647 (cl-defun jsonrpc--reply 648 (connection id method &key (result nil result-supplied-p) (error nil error-supplied-p)) 649 "Reply to CONNECTION's request ID with RESULT or ERROR." 650 (apply #'jsonrpc-connection-send connection 651 `(:id ,id 652 ,@(and result-supplied-p `(:result ,result)) 653 ,@(and error-supplied-p `(:error ,error)) 654 :method ,method))) 655 656 (defun jsonrpc--call-deferred (connection) 657 "Call CONNECTION's deferred actions, who may again defer themselves." 658 (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) 659 (jsonrpc--event 660 connection 'internal 661 :log-text (format "re-attempting deferred requests %s" 662 (mapcar (apply-partially #'nth 2) actions))) 663 (mapc #'funcall (mapcar #'car actions)))) 664 665 (defun jsonrpc--process-sentinel (proc change) 666 "Called when PROC undergoes CHANGE." 667 (let ((connection (process-get proc 'jsonrpc-connection))) 668 (jsonrpc--debug connection "Connection state change: `%s'" change) 669 (when (not (process-live-p proc)) 670 (with-current-buffer (jsonrpc-events-buffer connection) 671 (let ((inhibit-read-only t)) 672 (insert "\n----------b---y---e---b---y---e----------\n"))) 673 ;; Cancel outstanding timers 674 (mapc (jsonrpc-lambda (_id _method _success-fn _error-fn timer) 675 (when timer (cancel-timer timer))) 676 (jsonrpc--continuations connection)) 677 (maphash (lambda (_ triplet) 678 (pcase-let ((`(,_ ,timer ,_) triplet)) 679 (when timer (cancel-timer timer)))) 680 (jsonrpc--deferred-actions connection)) 681 (process-put proc 'jsonrpc-sentinel-cleanup-started t) 682 (unwind-protect 683 ;; Call all outstanding error handlers 684 (mapc (jsonrpc-lambda (_id _method _success-fn error-fn _timer) 685 (funcall error-fn '(:code -1 :message "Server died"))) 686 (jsonrpc--continuations connection)) 687 (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) 688 (delete-process proc) 689 (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) 690 (funcall (jsonrpc--on-shutdown connection) connection))))) 691 692 (defvar jsonrpc--in-process-filter nil 693 "Non-nil if inside `jsonrpc--process-filter'.") 694 695 (cl-defun jsonrpc--process-filter (proc string) 696 "Called when new data STRING has arrived for PROC." 697 (when jsonrpc--in-process-filter 698 ;; Problematic recursive process filters may happen if 699 ;; `jsonrpc-connection-receive', called by us, eventually calls 700 ;; client code which calls `process-send-string' (which see) to, 701 ;; say send a follow-up message. If that happens to writes enough 702 ;; bytes for pending output to be received, we will lose JSONRPC 703 ;; messages. In that case, remove recursiveness by re-scheduling 704 ;; ourselves to run from within a timer as soon as possible 705 ;; (bug#60088) 706 (run-at-time 0 nil #'jsonrpc--process-filter proc string) 707 (cl-return-from jsonrpc--process-filter)) 708 (when (buffer-live-p (process-buffer proc)) 709 (with-current-buffer (process-buffer proc) 710 (let* ((conn (process-get proc 'jsonrpc-connection)) 711 (expected-bytes (jsonrpc--expected-bytes conn))) 712 ;; Insert the text, advancing the process marker. 713 ;; 714 (save-excursion 715 (goto-char (process-mark proc)) 716 (let ((inhibit-read-only t)) (insert string)) 717 (set-marker (process-mark proc) (point))) 718 ;; Loop (more than one message might have arrived) 719 ;; 720 (unwind-protect 721 (let (done) 722 (while (not done) 723 (cond 724 ((not expected-bytes) 725 ;; Starting a new message 726 ;; 727 (setq expected-bytes 728 (and (search-forward-regexp 729 "\\(?:.*: .*\r\n\\)*Content-Length: \ 730 *\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n" 731 (+ (point) 100) 732 t) 733 (string-to-number (match-string 1)))) 734 (unless expected-bytes 735 (setq done :waiting-for-new-message))) 736 (t 737 ;; Attempt to complete a message body 738 ;; 739 (let ((available-bytes (- (position-bytes (process-mark proc)) 740 (position-bytes (point))))) 741 (cond 742 ((>= available-bytes 743 expected-bytes) 744 (let* ((message-end (byte-to-position 745 (+ (position-bytes (point)) 746 expected-bytes))) 747 message 748 ) 749 (unwind-protect 750 (save-restriction 751 (narrow-to-region (point) message-end) 752 (setq message 753 (condition-case-unless-debug oops 754 (jsonrpc--json-read) 755 (error 756 (jsonrpc--warn "Invalid JSON: %s %s" 757 (cdr oops) (buffer-string)) 758 nil))) 759 (when message 760 (setq message 761 (plist-put message :jsonrpc-json 762 (buffer-string))) 763 ;; Put new messages at the front of the queue, 764 ;; this is correct as the order is reversed 765 ;; before putting the timers on `timer-list'. 766 (push message 767 (process-get proc 'jsonrpc-mqueue)))) 768 (goto-char message-end) 769 (let ((inhibit-read-only t)) 770 (delete-region (point-min) (point))) 771 (setq expected-bytes nil)))) 772 (t 773 ;; Message is still incomplete 774 ;; 775 (setq done :waiting-for-more-bytes-in-this-message)))))))) 776 ;; Saved parsing state for next visit to this filter, which 777 ;; may well be a recursive one stemming from the tail call 778 ;; to `jsonrpc-connection-receive' below (bug#60088). 779 ;; 780 (setf (jsonrpc--expected-bytes conn) expected-bytes) 781 ;; Now, time to notify user code of one or more messages in 782 ;; order. Very often `jsonrpc-connection-receive' will exit 783 ;; non-locally (typically the reply to a request), so do 784 ;; this all this processing in top-level loops timer. 785 (cl-loop 786 ;; `timer-activate' orders timers by time, which is an 787 ;; very expensive operation when jsonrpc-mqueue is large, 788 ;; therefore the time object is reused for each timer 789 ;; created. 790 with time = (current-time) 791 for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg 792 do (let ((timer (timer-create))) 793 (timer-set-time timer time) 794 (timer-set-function timer 795 (lambda (conn msg) 796 (with-temp-buffer 797 (jsonrpc-connection-receive conn msg))) 798 (list conn msg)) 799 (timer-activate timer)))))))) 800 801 (defun jsonrpc--remove (conn id &optional deferred-spec) 802 "Cancel CONN's continuations for ID, including its timer, if it exists. 803 Also cancel \"deferred actions\" if DEFERRED-SPEC. 804 Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" 805 (with-slots ((conts -continuations) (defs -deferred-actions)) conn 806 (if deferred-spec (remhash deferred-spec defs)) 807 (when-let ((ass (assq id conts))) 808 (cl-destructuring-bind (_ _ _ _ timer) ass 809 (when timer (cancel-timer timer))) 810 (setf conts (delete ass conts)) 811 ass))) 812 813 (defun jsonrpc--schedule (conn id method success-fn error-fn timer) 814 (push (list id method success-fn error-fn timer) 815 (jsonrpc--continuations conn))) 816 817 (defun jsonrpc--continue (conn id &optional cont result error) 818 (pcase-let* ((`(,cont-id ,_method ,success-fn ,error-fn ,_timer) 819 cont) 820 (head (pop (jsonrpc--sync-request-alist conn))) 821 (anxious (cdr head))) 822 (cond 823 (anxious 824 (when (not (= (car head) id)) ; sanity check 825 (error "internal error: please report this bug")) 826 ;; If there are "anxious" `jsonrpc-request' continuations 827 ;; that should already have been run, they should run now. 828 ;; The main continuation -- if it exists -- should run 829 ;; before them. This order is important to preserve the 830 ;; throw to the catch tags in `jsonrpc-request' in 831 ;; order (bug#67945). 832 (cl-flet ((later (f arg) (run-at-time 0 nil f arg))) 833 (when cont-id 834 (if error (later error-fn error) 835 (later success-fn result))) 836 (cl-loop 837 for (acont ares aerr) in anxious 838 for (anx-id _method success-fn error-fn) = acont 839 do (jsonrpc--event 840 conn 'internal 841 :log-text (format "anxious continuation to %s running now" anx-id)) 842 if aerr do (later error-fn aerr) 843 else do (later success-fn ares)))) 844 (cont-id 845 ;; Else, just run the normal one, with plain funcall. 846 (if error (funcall error-fn error) 847 (funcall success-fn result))) 848 (t 849 ;; For clarity. This happens if the `jsonrpc-request' was 850 ;; canceled 851 )))) 852 853 (cl-defun jsonrpc--async-request-1 (connection 854 method 855 params 856 &rest args 857 &key success-fn error-fn timeout-fn 858 (timeout jsonrpc-default-request-timeout) 859 (deferred nil) 860 (sync-request nil)) 861 "Helper for `jsonrpc-request' and `jsonrpc-async-request'. 862 863 Return a list (ID TIMER). ID is the new request's ID, or nil if 864 the request was deferred. TIMER is a timer object set (or nil, if 865 TIMEOUT is nil)." 866 (pcase-let* ((buf (current-buffer)) (point (point)) 867 (`(,_ ,timer ,old-id) 868 (and deferred (gethash (list deferred buf) 869 (jsonrpc--deferred-actions connection)))) 870 (id (or old-id (cl-incf (jsonrpc--next-request-id connection)))) 871 (maybe-timer 872 (lambda () 873 (when timeout 874 (or timer 875 (setq 876 timer 877 (run-with-timer 878 timeout nil 879 (lambda () 880 (jsonrpc--remove connection id (list deferred buf)) 881 (jsonrpc--event 882 connection 'internal 883 :log-text (format "timed-out request '%s'" method) 884 :id id) 885 (when timeout-fn (funcall timeout-fn)))))))))) 886 (when deferred 887 (if (jsonrpc-connection-ready-p connection deferred) 888 ;; Server is ready, we jump below and send it immediately. 889 (remhash (list deferred buf) (jsonrpc--deferred-actions connection)) 890 ;; Otherwise, save in `jsonrpc--deferred-actions' and exit non-locally 891 (unless old-id 892 (jsonrpc--event 893 connection 'internal 894 :log-text (format "deferring request '%s'" method) 895 :id id)) 896 (puthash (list deferred buf) 897 (list (lambda () 898 (when (buffer-live-p buf) 899 (with-current-buffer buf 900 (save-excursion (goto-char point) 901 (apply #'jsonrpc--async-request-1 902 connection 903 method params args))))) 904 (funcall maybe-timer) id) 905 (jsonrpc--deferred-actions connection)) 906 (cl-return-from jsonrpc--async-request-1 (list id timer)))) 907 ;; Really send it thru the wire 908 ;; 909 (jsonrpc-connection-send connection 910 :id id 911 :method method 912 :params params) 913 ;; Setup some control structures 914 ;; 915 (when sync-request 916 (push (list id) (jsonrpc--sync-request-alist connection))) 917 918 (jsonrpc--schedule 919 connection id method 920 (or success-fn 921 (lambda (&rest _ignored) 922 (jsonrpc--event 923 connection 'internal 924 :log-text (format "success ignored") 925 :id id))) 926 (or error-fn 927 (jsonrpc-lambda (&key code message &allow-other-keys) 928 (jsonrpc--event 929 connection 'internal 930 :log-text (format "error %s ignored: %s ignored" 931 code message) 932 :id id))) 933 (funcall maybe-timer)) 934 (list id timer))) 935 936 (defun jsonrpc--message (format &rest args) 937 "Message out with FORMAT with ARGS." 938 (message "[jsonrpc] %s" (apply #'format format args))) 939 940 (defun jsonrpc--debug (server format &rest args) 941 "Debug message for SERVER with FORMAT and ARGS." 942 (with-current-buffer (jsonrpc-events-buffer server) 943 (jsonrpc--log-event 944 server 'internal 945 :log-text (apply #'format format args) 946 :type 'debug))) 947 948 (defun jsonrpc--warn (format &rest args) 949 "Warning message with FORMAT and ARGS." 950 (apply #'jsonrpc--message (concat "(warning) " format) args) 951 (let ((warning-minimum-level :error)) 952 (display-warning 'jsonrpc 953 (apply #'format format args) 954 :warning))) 955 956 (cl-defun jsonrpc--event (connection 957 origin 958 &rest plist 959 &key _kind _json _message _foreign-message _log-text 960 &allow-other-keys) 961 (with-current-buffer (jsonrpc-events-buffer connection) 962 (run-hook-wrapped 'jsonrpc-event-hook 963 (lambda (fn) 964 (condition-case oops 965 (apply fn connection origin plist) 966 (error 967 (jsonrpc--message "event hook '%s' errored (%s). Removing it" 968 fn oops) 969 (remove-hook 'jsonrpc-event-hook fn))))))) 970 971 (defvar jsonrpc-event-hook (list #'jsonrpc--log-event) 972 "Hook run when JSON-RPC events are emitted. 973 This hooks runs in the events buffer of every `jsonrpc-connection' 974 when an event is originated by either endpoint. Each hook function 975 is passed the arguments described by the lambda list: 976 977 (CONNECTION ORIGIN &key JSON KIND MESSAGE FOREIGN-MESSAGE LOG-TEXT 978 &allow-other-keys) 979 980 CONNECTION the `jsonrpc-connection' instance. 981 ORIGIN one of the symbols `client' ,`server'. 982 JSON the raw JSON string content. 983 KIND one of the symbols `request' ,`notification', 984 `reply'. 985 MESSAGE a plist representing the exchanged message in 986 jsonrpc.el's internal format 987 FOREIGN-MESSAGE a plist representing the exchanged message in 988 the remote endpoint's format. 989 LOG-TEXT text used for events of `internal' origin. 990 ID id of a message that this event refers to. 991 TYPE `error', `debug' or the default `info'. 992 993 Except for CONNECTION and ORIGIN all other keys are optional. 994 Unlisted keys may appear in the plist. 995 996 Do not use this hook to write JSON-RPC protocols, use other parts 997 of the API instead.") 998 999 (cl-defun jsonrpc--log-event (connection origin 1000 &key _kind message 1001 foreign-message log-text json 1002 type ((:id ref-id)) 1003 &allow-other-keys) 1004 "Log a JSONRPC-related event. Installed in `jsonrpc-event-hook'." 1005 (let* ((props (slot-value connection '-events-buffer-config)) 1006 (max (plist-get props :size)) 1007 (format (plist-get props :format))) 1008 (when (or (null max) (cl-plusp max)) 1009 (cl-destructuring-bind (&key method id error &allow-other-keys) message 1010 (let* ((inhibit-read-only t) 1011 (depth (length 1012 (jsonrpc--sync-request-alist connection))) 1013 (preamble (format "[jsonrpc] %s[%s]%s " 1014 (pcase type ('error "E") ('debug "D") 1015 (_ (pcase origin 1016 ('internal "i") 1017 (_ "e")))) 1018 (format-time-string "%H:%M:%S.%3N") 1019 (if (eq origin 'internal) 1020 (if ref-id (format " [%s]" ref-id) "") 1021 (format " %s%s %s%s" 1022 (make-string (* 2 depth) ? ) 1023 (pcase origin 1024 ('client "-->") 1025 ('server "<--") 1026 (_ "")) 1027 (or method "") 1028 (if id (format "[%s]" id) ""))))) 1029 (msg 1030 (pcase format 1031 ('full (format "%s%s\n" preamble (or json log-text))) 1032 ('short (format "%s%s\n" preamble (or log-text ""))) 1033 (_ 1034 (format "%s%s" preamble 1035 (or (and foreign-message 1036 (let ((lisp-indent-function ;bug#68072 1037 #'lisp-indent-function)) 1038 (concat "\n" (pp-to-string 1039 foreign-message)))) 1040 (concat log-text "\n"))))))) 1041 (goto-char (point-max)) 1042 ;; XXX: could use `run-at-time' to delay server logs 1043 ;; slightly to play nice with verbose servers' stderr. 1044 (when error 1045 (setq msg (propertize msg 'face 'error))) 1046 (insert-before-markers msg) 1047 ;; Trim the buffer if it's too large 1048 (when max 1049 (save-excursion 1050 (goto-char (point-min)) 1051 (while (> (buffer-size) max) 1052 (delete-region (point) (progn (forward-line 1) 1053 (forward-sexp 1) 1054 (forward-line 2) 1055 (point))))))))))) 1056 1057 (defun jsonrpc--forwarding-buffer (name prefix conn) 1058 "Helper for `jsonrpc-process-connection' helpers. 1059 Make a stderr buffer named NAME, forwarding lines prefixed by 1060 PREFIX to CONN's events buffer." 1061 (with-current-buffer (get-buffer-create name) 1062 (let ((inhibit-read-only t)) 1063 (fundamental-mode) 1064 (erase-buffer) 1065 (buffer-disable-undo) 1066 (add-hook 1067 'after-change-functions 1068 (lambda (beg _end _pre-change-len) 1069 (cl-loop initially (goto-char beg) 1070 do (forward-line) 1071 when (bolp) 1072 for line = (buffer-substring 1073 (line-beginning-position 0) 1074 (line-end-position 0)) 1075 do (with-current-buffer (jsonrpc-events-buffer conn) 1076 (goto-char (point-max)) 1077 (let ((inhibit-read-only t)) 1078 (insert 1079 (propertize (format "%s %s\n" prefix line) 1080 'face 'shadow)))) 1081 until (eobp))) 1082 nil t)) 1083 (current-buffer))) 1084 1085 1086 ;;;; More convenience utils 1087 (cl-defun jsonrpc-autoport-bootstrap (name contact 1088 &key connect-args) 1089 "Use CONTACT to start network server, then connect to it. 1090 1091 Return function suitable for the :PROCESS initarg of 1092 `jsonrpc-process-connection' (which see). 1093 1094 CONTACT is a list where all the elements are strings except for 1095 one, which is usuallky the keyword `:autoport'. 1096 1097 When the returned function is called it will start a program 1098 using a command based on CONTACT, where `:autoport' is 1099 substituted by a locally free network port. Thereafter, a 1100 network is made to this port. 1101 1102 Instead of the keyword `:autoport', a cons cell (:autoport 1103 FORMAT-FN) is also accepted. In that case FORMAT-FN is passed 1104 the port number and should return a string used for the 1105 substitution. 1106 1107 The internal processes and control buffers are named after NAME. 1108 1109 CONNECT-ARGS are passed as additional arguments to 1110 `open-network-stream'." 1111 (lambda (conn) 1112 (let* ((port-probe (make-network-process :name "jsonrpc-port-probe-dummy" 1113 :server t 1114 :host "localhost" 1115 :service 0)) 1116 (port-number (unwind-protect 1117 (process-contact port-probe :service) 1118 (delete-process port-probe))) 1119 (inferior-buffer (jsonrpc--forwarding-buffer 1120 (format " *%s inferior output*" name) 1121 "[inferior]" 1122 conn)) 1123 (cmd (cl-loop for e in contact 1124 if (eq e :autoport) collect (format "%s" port-number) 1125 else if (eq (car-safe e) :autoport) 1126 collect (funcall (cdr e) port-number) 1127 else collect e)) 1128 inferior np) 1129 (unwind-protect 1130 (progn 1131 (message "[jsonrpc] Attempting to start `%s'" 1132 (string-join cmd " ")) 1133 (setq inferior 1134 (make-process 1135 :name (format "inferior (%s)" name) 1136 :buffer inferior-buffer 1137 :noquery t 1138 :command cmd)) 1139 (setq np 1140 (cl-loop 1141 repeat 10 for i from 0 1142 do (accept-process-output nil 0.5) 1143 while (process-live-p inferior) 1144 do (message 1145 "[jsonrpc] %sTrying to connect to localhost:%s (attempt %s)" 1146 (if (zerop i) "Started. " "") 1147 port-number (1+ i)) 1148 thereis (ignore-errors 1149 (apply #'open-network-stream 1150 (format "autostart (%s)" name) 1151 nil 1152 "localhost" port-number connect-args)))) 1153 (setf (slot-value conn '-autoport-inferior) inferior) 1154 np) 1155 (cond ((and (process-live-p np) 1156 (process-live-p inferior)) 1157 (message "[jsonrpc] Done, connected to %s!" port-number)) 1158 (t 1159 (when inferior (delete-process inferior)) 1160 (when np (delete-process np)) 1161 (error "[jsonrpc] Could not start and/or connect"))))))) 1162 1163 (defun jsonrpc-continuation-count (conn) 1164 "Number of outstanding continuations for CONN." 1165 (length (jsonrpc--continuations conn))) 1166 1167 (provide 'jsonrpc) 1168 ;;; jsonrpc.el ends here