jsonrpc.el (32779B)
1 ;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. 4 5 ;; Author: João Távora <joaotavora@gmail.com> 6 ;; Keywords: processes, languages, extensions 7 ;; Version: 1.0.14 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 program is free software; you can redistribute it and/or modify 14 ;; it under the terms of the GNU General Public License as published by 15 ;; the Free Software Foundation, either version 3 of the License, or 16 ;; (at your option) any later version. 17 18 ;; This program is distributed in the hope that it will be useful, 19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 21 ;; GNU General Public License for more details. 22 23 ;; You should have received a copy of the GNU General Public License 24 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 25 26 ;;; Commentary: 27 28 ;; This library implements the JSONRPC 2.0 specification as described 29 ;; in https://www.jsonrpc.org/. As the name suggests, JSONRPC is a 30 ;; generic Remote Procedure Call protocol designed around JSON 31 ;; objects. To learn how to write JSONRPC programs with this library, 32 ;; see Info node `(elisp)JSONRPC'." 33 ;; 34 ;; This library was originally extracted from eglot.el, an Emacs LSP 35 ;; client, which you should see for an example usage. 36 ;; 37 ;;; Code: 38 39 (require 'cl-lib) 40 (require 'eieio) 41 (eval-when-compile (require 'subr-x)) 42 (require 'warnings) 43 (require 'pcase) 44 (require 'ert) ; to escape a `condition-case-unless-debug' 45 46 47 ;;; Public API 48 ;;; 49 50 (defclass jsonrpc-connection () 51 ((name 52 :accessor jsonrpc-name 53 :initarg :name 54 :documentation "A name for the connection") 55 (-request-dispatcher 56 :accessor jsonrpc--request-dispatcher 57 :initform #'ignore 58 :initarg :request-dispatcher 59 :documentation "Dispatcher for remotely invoked requests.") 60 (-notification-dispatcher 61 :accessor jsonrpc--notification-dispatcher 62 :initform #'ignore 63 :initarg :notification-dispatcher 64 :documentation "Dispatcher for remotely invoked notifications.") 65 (last-error 66 :accessor jsonrpc-last-error 67 :documentation "Last JSONRPC error message received from endpoint.") 68 (-request-continuations 69 :initform (make-hash-table) 70 :accessor jsonrpc--request-continuations 71 :documentation "A hash table of request ID to continuation lambdas.") 72 (-events-buffer 73 :accessor jsonrpc--events-buffer 74 :documentation "A buffer pretty-printing the JSONRPC events") 75 (-events-buffer-scrollback-size 76 :initarg :events-buffer-scrollback-size 77 :accessor jsonrpc--events-buffer-scrollback-size 78 :documentation "Max size of events buffer. 0 disables, nil means infinite.") 79 (-deferred-actions 80 :initform (make-hash-table :test #'equal) 81 :accessor jsonrpc--deferred-actions 82 :documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\ 83 a saved DEFERRED `async-request' from BUF, to be sent not later\ 84 than TIMER as ID.") 85 (-next-request-id 86 :initform 0 87 :accessor jsonrpc--next-request-id 88 :documentation "Next number used for a request")) 89 :documentation "Base class representing a JSONRPC connection. 90 The following initargs are accepted: 91 92 :NAME (mandatory), a string naming the connection 93 94 :REQUEST-DISPATCHER (optional), a function of three 95 arguments (CONN METHOD PARAMS) for handling JSONRPC requests. 96 CONN is a `jsonrpc-connection' object, method is a symbol, and 97 PARAMS is a plist representing a JSON object. The function is 98 expected to return a JSONRPC result, a plist of (:result 99 RESULT) or signal an error of type `jsonrpc-error'. 100 101 :NOTIFICATION-DISPATCHER (optional), a function of three 102 arguments (CONN METHOD PARAMS) for handling JSONRPC 103 notifications. CONN, METHOD and PARAMS are the same as in 104 :REQUEST-DISPATCHER.") 105 106 ;;; API mandatory 107 (cl-defgeneric jsonrpc-connection-send (conn &key id method params result error) 108 "Send a JSONRPC message to connection CONN. 109 ID, METHOD, PARAMS, RESULT and ERROR.") 110 111 ;;; API optional 112 (cl-defgeneric jsonrpc-shutdown (conn) 113 "Shutdown the JSONRPC connection CONN.") 114 115 ;;; API optional 116 (cl-defgeneric jsonrpc-running-p (conn) 117 "Tell if the JSONRPC connection CONN is still running.") 118 119 ;;; API optional 120 (cl-defgeneric jsonrpc-connection-ready-p (connection what) 121 "Tell if CONNECTION is ready for WHAT in current buffer. 122 If it isn't, a request which was passed a value to the 123 `:deferred' keyword argument will be deferred to the future. 124 WHAT is whatever was passed the as the value to that argument. 125 126 By default, all connections are ready for sending all requests 127 immediately." 128 (:method (_s _what) ;; by default all connections are ready 129 t)) 130 131 132 ;;; Convenience 133 ;;; 134 (cl-defmacro jsonrpc-lambda (cl-lambda-list &body body) 135 (declare (indent 1) (debug (sexp &rest form))) 136 (let ((e (cl-gensym "jsonrpc-lambda-elem"))) 137 `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e)))) 138 139 (defun jsonrpc-events-buffer (connection) 140 "Get or create JSONRPC events buffer for CONNECTION." 141 (let* ((probe (jsonrpc--events-buffer connection)) 142 (buffer (or (and (buffer-live-p probe) 143 probe) 144 (let ((buffer (get-buffer-create 145 (format "*%s events*" 146 (jsonrpc-name connection))))) 147 (with-current-buffer buffer 148 (buffer-disable-undo) 149 (read-only-mode t) 150 (setf (jsonrpc--events-buffer connection) buffer)) 151 buffer)))) 152 buffer)) 153 154 (defun jsonrpc-forget-pending-continuations (connection) 155 "Stop waiting for responses from the current JSONRPC CONNECTION." 156 (clrhash (jsonrpc--request-continuations connection))) 157 158 (defun jsonrpc-connection-receive (connection message) 159 "Process MESSAGE just received from CONNECTION. 160 This function will destructure MESSAGE and call the appropriate 161 dispatcher in CONNECTION." 162 (cl-destructuring-bind (&key method id error params result _jsonrpc) 163 message 164 (let (continuations) 165 (jsonrpc--log-event connection message 'server) 166 (setf (jsonrpc-last-error connection) error) 167 (cond 168 (;; A remote request 169 (and method id) 170 (let* ((debug-on-error (and debug-on-error (not (ert-running-test)))) 171 (reply 172 (condition-case-unless-debug _ignore 173 (condition-case oops 174 `(:result ,(funcall (jsonrpc--request-dispatcher connection) 175 connection (intern method) params)) 176 (jsonrpc-error 177 `(:error 178 (:code 179 ,(or (alist-get 'jsonrpc-error-code (cdr oops)) -32603) 180 :message ,(or (alist-get 'jsonrpc-error-message 181 (cdr oops)) 182 "Internal error"))))) 183 (error 184 '(:error (:code -32603 :message "Internal error")))))) 185 (apply #'jsonrpc--reply connection id reply))) 186 (;; A remote notification 187 method 188 (funcall (jsonrpc--notification-dispatcher connection) 189 connection (intern method) params)) 190 (;; A remote response 191 (setq continuations 192 (and id (gethash id (jsonrpc--request-continuations connection)))) 193 (let ((timer (nth 2 continuations))) 194 (when timer (cancel-timer timer))) 195 (remhash id (jsonrpc--request-continuations connection)) 196 (if error (funcall (nth 1 continuations) error) 197 (funcall (nth 0 continuations) result)))) 198 (jsonrpc--call-deferred connection)))) 199 200 201 ;;; Contacting the remote endpoint 202 ;;; 203 (defun jsonrpc-error (&rest args) 204 "Error out with FORMAT and ARGS. 205 If invoked inside a dispatcher function, this function is suitable 206 for replying to the remote endpoint with an error message. 207 208 ARGS can be of the form (FORMAT-STRING . MOREARGS) for replying 209 with a -32603 error code and a message formed by formatting 210 FORMAT-STRING with MOREARGS. 211 212 Alternatively ARGS can be plist representing a JSONRPC error 213 object, using the keywords `:code', `:message' and `:data'." 214 (if (stringp (car args)) 215 (let ((msg 216 (apply #'format-message (car args) (cdr args)))) 217 (signal 'jsonrpc-error 218 `(,msg 219 (jsonrpc-error-code . ,32603) 220 (jsonrpc-error-message . ,msg)))) 221 (cl-destructuring-bind (&key code message data) args 222 (signal 'jsonrpc-error 223 `(,(format "[jsonrpc] error ") 224 (jsonrpc-error-code . ,code) 225 (jsonrpc-error-message . ,message) 226 (jsonrpc-error-data . ,data)))))) 227 228 (cl-defun jsonrpc-async-request (connection 229 method 230 params 231 &rest args 232 &key _success-fn _error-fn 233 _timeout-fn 234 _timeout _deferred) 235 "Make a request to CONNECTION, expecting a reply, return immediately. 236 The JSONRPC request is formed by METHOD, a symbol, and PARAMS a 237 JSON object. 238 239 The caller can expect SUCCESS-FN or ERROR-FN to be called with a 240 JSONRPC `:result' or `:error' object, respectively. If this 241 doesn't happen after TIMEOUT seconds (defaults to 242 `jrpc-default-request-timeout'), the caller can expect TIMEOUT-FN 243 to be called with no arguments. The default values of SUCCESS-FN, 244 ERROR-FN and TIMEOUT-FN simply log the events into 245 `jsonrpc-events-buffer'. 246 247 If DEFERRED is non-nil, maybe defer the request to a future time 248 when the server is thought to be ready according to 249 `jsonrpc-connection-ready-p' (which see). The request might 250 never be sent at all, in case it is overridden in the meantime by 251 a new request with identical DEFERRED and for the same buffer. 252 However, in that situation, the original timeout is kept. 253 254 Returns nil." 255 (apply #'jsonrpc--async-request-1 connection method params args) 256 nil) 257 258 (cl-defun jsonrpc-request (connection 259 method params &key 260 deferred timeout 261 cancel-on-input 262 cancel-on-input-retval) 263 "Make a request to CONNECTION, wait for a reply. 264 Like `jsonrpc-async-request' for CONNECTION, METHOD and PARAMS, 265 but synchronous. 266 267 Except in the case of a non-nil CANCEL-ON-INPUT (explained 268 below), this function doesn't exit until anything interesting 269 happens (success reply, error reply, or timeout). Furthermore, 270 it only exits locally (returning the JSONRPC result object) if 271 the request is successful, otherwise it exits non-locally with an 272 error of type `jsonrpc-error'. 273 274 DEFERRED and TIMEOUT as in `jsonrpc-async-request', which see. 275 276 If CANCEL-ON-INPUT is non-nil and the user inputs something while 277 the function is waiting, then it exits immediately, returning 278 CANCEL-ON-INPUT-RETVAL. Any future replies (normal or error) are 279 ignored." 280 (let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer 281 cancelled 282 (retval 283 (unwind-protect 284 (catch tag 285 (setq 286 id-and-timer 287 (apply 288 #'jsonrpc--async-request-1 289 connection method params 290 :success-fn (lambda (result) 291 (unless cancelled 292 (throw tag `(done ,result)))) 293 :error-fn 294 (jsonrpc-lambda 295 (&key code message data) 296 (unless cancelled 297 (throw tag `(error (jsonrpc-error-code . ,code) 298 (jsonrpc-error-message . ,message) 299 (jsonrpc-error-data . ,data))))) 300 :timeout-fn 301 (lambda () 302 (unless cancelled 303 (throw tag '(error (jsonrpc-error-message . "Timed out"))))) 304 `(,@(when deferred `(:deferred ,deferred)) 305 ,@(when timeout `(:timeout ,timeout))))) 306 (cond (cancel-on-input 307 (unwind-protect 308 (let ((inhibit-quit t)) (while (sit-for 30))) 309 (setq cancelled t)) 310 `(cancelled ,cancel-on-input-retval)) 311 (t (while t (accept-process-output nil 30))))) 312 ;; In normal operation, cancellation is handled by the 313 ;; timeout function and response filter, but we still have 314 ;; to protect against user-quit (C-g) or the 315 ;; `cancel-on-input' case. 316 (pcase-let* ((`(,id ,timer) id-and-timer)) 317 (remhash id (jsonrpc--request-continuations connection)) 318 (remhash (list deferred (current-buffer)) 319 (jsonrpc--deferred-actions connection)) 320 (when timer (cancel-timer timer)))))) 321 (when (eq 'error (car retval)) 322 (signal 'jsonrpc-error 323 (cons 324 (format "request id=%s failed:" (car id-and-timer)) 325 (cdr retval)))) 326 (cadr retval))) 327 328 (cl-defun jsonrpc-notify (connection method params) 329 "Notify CONNECTION of something, don't expect a reply." 330 (jsonrpc-connection-send connection 331 :method method 332 :params params)) 333 334 (define-obsolete-variable-alias 'jrpc-default-request-timeout 335 'jsonrpc-default-request-timeout "28.1") 336 337 (defconst jsonrpc-default-request-timeout 10 338 "Time in seconds before timing out a JSONRPC request.") 339 340 341 ;;; Specific to `jsonrpc-process-connection' 342 ;;; 343 344 (defclass jsonrpc-process-connection (jsonrpc-connection) 345 ((-process 346 :initarg :process :accessor jsonrpc--process 347 :documentation "Process object wrapped by the this connection.") 348 (-expected-bytes 349 :accessor jsonrpc--expected-bytes 350 :documentation "How many bytes declared by server.") 351 (-on-shutdown 352 :accessor jsonrpc--on-shutdown 353 :initform #'ignore 354 :initarg :on-shutdown 355 :documentation "Function run when the process dies.")) 356 :documentation "A JSONRPC connection over an Emacs process. 357 The following initargs are accepted: 358 359 :PROCESS (mandatory), a live running Emacs process object or a 360 function of no arguments producing one such object. The process 361 represents either a pipe connection to locally running process or 362 a stream connection to a network host. The remote endpoint is 363 expected to understand JSONRPC messages with basic HTTP-style 364 enveloping headers such as \"Content-Length:\". 365 366 :ON-SHUTDOWN (optional), a function of one argument, the 367 connection object, called when the process dies .") 368 369 (cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots) 370 (cl-call-next-method) 371 (cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots 372 ;; FIXME: notice the undocumented bad coupling in the stderr 373 ;; buffer name, it must be named exactly like this we expect when 374 ;; calling `make-process'. If there were a `set-process-stderr' 375 ;; like there is `set-process-buffer' we wouldn't need this and 376 ;; could use a pipe with a process filter instead of 377 ;; `after-change-functions'. Alternatively, we need a new initarg 378 ;; (but maybe not a slot). 379 (let ((calling-buffer (current-buffer))) 380 (with-current-buffer (get-buffer-create (format "*%s stderr*" name)) 381 (let ((inhibit-read-only t) 382 (hidden-name (concat " " (buffer-name)))) 383 (erase-buffer) 384 (buffer-disable-undo) 385 (add-hook 386 'after-change-functions 387 (lambda (beg _end _pre-change-len) 388 (cl-loop initially (goto-char beg) 389 do (forward-line) 390 when (bolp) 391 for line = (buffer-substring 392 (line-beginning-position 0) 393 (line-end-position 0)) 394 do (with-current-buffer (jsonrpc-events-buffer conn) 395 (goto-char (point-max)) 396 (let ((inhibit-read-only t)) 397 (insert (format "[stderr] %s\n" line)))) 398 until (eobp))) 399 nil t) 400 ;; If we are correctly coupled to the client, the process 401 ;; now created should pick up the current stderr buffer, 402 ;; which we immediately rename 403 (setq proc (if (functionp proc) 404 (with-current-buffer calling-buffer (funcall proc)) 405 proc)) 406 (ignore-errors (kill-buffer hidden-name)) 407 (rename-buffer hidden-name) 408 (process-put proc 'jsonrpc-stderr (current-buffer)) 409 (read-only-mode t)))) 410 (setf (jsonrpc--process conn) proc) 411 (set-process-buffer proc (get-buffer-create (format " *%s output*" name))) 412 (set-process-filter proc #'jsonrpc--process-filter) 413 (set-process-sentinel proc #'jsonrpc--process-sentinel) 414 (with-current-buffer (process-buffer proc) 415 (buffer-disable-undo) 416 (set-marker (process-mark proc) (point-min)) 417 (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t))) 418 (process-put proc 'jsonrpc-connection conn))) 419 420 (cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection) 421 &rest args 422 &key 423 _id 424 method 425 _params 426 _result 427 _error 428 _partial) 429 "Send MESSAGE, a JSON object, to CONNECTION." 430 (when method 431 (plist-put args :method 432 (cond ((keywordp method) (substring (symbol-name method) 1)) 433 ((and method (symbolp method)) (symbol-name method))))) 434 (let* ( (message `(:jsonrpc "2.0" ,@args)) 435 (json (jsonrpc--json-encode message)) 436 (headers 437 `(("Content-Length" . ,(format "%d" (string-bytes json))) 438 ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8") 439 ))) 440 (process-send-string 441 (jsonrpc--process connection) 442 (cl-loop for (header . value) in headers 443 concat (concat header ": " value "\r\n") into header-section 444 finally return (format "%s\r\n%s" header-section json))) 445 (jsonrpc--log-event connection message 'client))) 446 447 (defun jsonrpc-process-type (conn) 448 "Return the `process-type' of JSONRPC connection CONN." 449 (process-type (jsonrpc--process conn))) 450 451 (cl-defmethod jsonrpc-running-p ((conn jsonrpc-process-connection)) 452 "Return non-nil if JSONRPC connection CONN is running." 453 (process-live-p (jsonrpc--process conn))) 454 455 (cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection) 456 &optional cleanup) 457 "Wait for JSONRPC connection CONN to shutdown. 458 With optional CLEANUP, kill any associated buffers." 459 (unwind-protect 460 (cl-loop 461 with proc = (jsonrpc--process conn) for i from 0 462 while (not (process-get proc 'jsonrpc-sentinel-cleanup-started)) 463 unless (zerop i) do 464 (jsonrpc--warn "Sentinel for %s still hasn't run, deleting it!" proc) 465 do 466 (delete-process proc) 467 (accept-process-output nil 0.1)) 468 (when cleanup 469 (kill-buffer (process-buffer (jsonrpc--process conn))) 470 (kill-buffer (jsonrpc-stderr-buffer conn))))) 471 472 (defun jsonrpc-stderr-buffer (conn) 473 "Get CONN's standard error buffer, if any." 474 (process-get (jsonrpc--process conn) 'jsonrpc-stderr)) 475 476 477 ;;; Private stuff 478 ;;; 479 (define-error 'jsonrpc-error "jsonrpc-error") 480 481 (defalias 'jsonrpc--json-read 482 (if (fboundp 'json-parse-buffer) 483 (lambda () 484 (json-parse-buffer :object-type 'plist 485 :null-object nil 486 :false-object :json-false)) 487 (require 'json) 488 (defvar json-object-type) 489 (declare-function json-read "json" ()) 490 (lambda () 491 (let ((json-object-type 'plist)) 492 (json-read)))) 493 "Read JSON object in buffer, move point to end of buffer.") 494 495 (defalias 'jsonrpc--json-encode 496 (if (fboundp 'json-serialize) 497 (lambda (object) 498 (json-serialize object 499 :false-object :json-false 500 :null-object nil)) 501 (require 'json) 502 (defvar json-false) 503 (defvar json-null) 504 (declare-function json-encode "json" (object)) 505 (lambda (object) 506 (let ((json-false :json-false) 507 (json-null nil)) 508 (json-encode object)))) 509 "Encode OBJECT into a JSON string.") 510 511 (cl-defun jsonrpc--reply 512 (connection id &key (result nil result-supplied-p) (error nil error-supplied-p)) 513 "Reply to CONNECTION's request ID with RESULT or ERROR." 514 (apply #'jsonrpc-connection-send connection 515 `(:id ,id 516 ,@(and result-supplied-p `(:result ,result)) 517 ,@(and error-supplied-p `(:error ,error))))) 518 519 (defun jsonrpc--call-deferred (connection) 520 "Call CONNECTION's deferred actions, who may again defer themselves." 521 (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) 522 (jsonrpc--debug connection `(:maybe-run-deferred 523 ,(mapcar (apply-partially #'nth 2) actions))) 524 (mapc #'funcall (mapcar #'car actions)))) 525 526 (defun jsonrpc--process-sentinel (proc change) 527 "Called when PROC undergoes CHANGE." 528 (let ((connection (process-get proc 'jsonrpc-connection))) 529 (jsonrpc--debug connection `(:message "Connection state changed" :change ,change)) 530 (when (not (process-live-p proc)) 531 (with-current-buffer (jsonrpc-events-buffer connection) 532 (let ((inhibit-read-only t)) 533 (insert "\n----------b---y---e---b---y---e----------\n"))) 534 ;; Cancel outstanding timers 535 (maphash (lambda (_id triplet) 536 (pcase-let ((`(,_success ,_error ,timeout) triplet)) 537 (when timeout (cancel-timer timeout)))) 538 (jsonrpc--request-continuations connection)) 539 (process-put proc 'jsonrpc-sentinel-cleanup-started t) 540 (unwind-protect 541 ;; Call all outstanding error handlers 542 (maphash (lambda (_id triplet) 543 (pcase-let ((`(,_success ,error ,_timeout) triplet)) 544 (funcall error '(:code -1 :message "Server died")))) 545 (jsonrpc--request-continuations connection)) 546 (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) 547 (delete-process proc) 548 (funcall (jsonrpc--on-shutdown connection) connection))))) 549 550 (defun jsonrpc--process-filter (proc string) 551 "Called when new data STRING has arrived for PROC." 552 (when (buffer-live-p (process-buffer proc)) 553 (with-current-buffer (process-buffer proc) 554 (let* ((inhibit-read-only t) 555 (connection (process-get proc 'jsonrpc-connection)) 556 (expected-bytes (jsonrpc--expected-bytes connection))) 557 ;; Insert the text, advancing the process marker. 558 ;; 559 (save-excursion 560 (goto-char (process-mark proc)) 561 (insert string) 562 (set-marker (process-mark proc) (point))) 563 ;; Loop (more than one message might have arrived) 564 ;; 565 (unwind-protect 566 (let (done) 567 (while (not done) 568 (cond 569 ((not expected-bytes) 570 ;; Starting a new message 571 ;; 572 (setq expected-bytes 573 (and (search-forward-regexp 574 "\\(?:.*: .*\r\n\\)*Content-Length: \ 575 *\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n" 576 (+ (point) 100) 577 t) 578 (string-to-number (match-string 1)))) 579 (unless expected-bytes 580 (setq done :waiting-for-new-message))) 581 (t 582 ;; Attempt to complete a message body 583 ;; 584 (let ((available-bytes (- (position-bytes (process-mark proc)) 585 (position-bytes (point))))) 586 (cond 587 ((>= available-bytes 588 expected-bytes) 589 (let* ((message-end (byte-to-position 590 (+ (position-bytes (point)) 591 expected-bytes)))) 592 (unwind-protect 593 (save-restriction 594 (narrow-to-region (point) message-end) 595 (let* ((json-message 596 (condition-case-unless-debug oops 597 (jsonrpc--json-read) 598 (error 599 (jsonrpc--warn "Invalid JSON: %s %s" 600 (cdr oops) (buffer-string)) 601 nil)))) 602 (when json-message 603 ;; Process content in another 604 ;; buffer, shielding proc buffer from 605 ;; tamper 606 (with-temp-buffer 607 (jsonrpc-connection-receive connection 608 json-message))))) 609 (goto-char message-end) 610 (delete-region (point-min) (point)) 611 (setq expected-bytes nil)))) 612 (t 613 ;; Message is still incomplete 614 ;; 615 (setq done :waiting-for-more-bytes-in-this-message)))))))) 616 ;; Saved parsing state for next visit to this filter 617 ;; 618 (setf (jsonrpc--expected-bytes connection) expected-bytes)))))) 619 620 (cl-defun jsonrpc--async-request-1 (connection 621 method 622 params 623 &rest args 624 &key success-fn error-fn timeout-fn 625 (timeout jsonrpc-default-request-timeout) 626 (deferred nil)) 627 "Does actual work for `jsonrpc-async-request'. 628 629 Return a list (ID TIMER). ID is the new request's ID, or nil if 630 the request was deferred. TIMER is a timer object set (or nil, if 631 TIMEOUT is nil)." 632 (pcase-let* ((buf (current-buffer)) (point (point)) 633 (`(,_ ,timer ,old-id) 634 (and deferred (gethash (list deferred buf) 635 (jsonrpc--deferred-actions connection)))) 636 (id (or old-id (cl-incf (jsonrpc--next-request-id connection)))) 637 (make-timer 638 (lambda ( ) 639 (when timeout 640 (run-with-timer 641 timeout nil 642 (lambda () 643 (remhash id (jsonrpc--request-continuations connection)) 644 (remhash (list deferred buf) 645 (jsonrpc--deferred-actions connection)) 646 (if timeout-fn (funcall timeout-fn) 647 (jsonrpc--debug 648 connection `(:timed-out ,method :id ,id 649 :params ,params))))))))) 650 (when deferred 651 (if (jsonrpc-connection-ready-p connection deferred) 652 ;; Server is ready, we jump below and send it immediately. 653 (remhash (list deferred buf) (jsonrpc--deferred-actions connection)) 654 ;; Otherwise, save in `jsonrpc--deferred-actions' and exit non-locally 655 (unless old-id 656 (jsonrpc--debug connection `(:deferring ,method :id ,id :params 657 ,params))) 658 (puthash (list deferred buf) 659 (list (lambda () 660 (when (buffer-live-p buf) 661 (with-current-buffer buf 662 (save-excursion (goto-char point) 663 (apply #'jsonrpc-async-request 664 connection 665 method params args))))) 666 (or timer (setq timer (funcall make-timer))) id) 667 (jsonrpc--deferred-actions connection)) 668 (cl-return-from jsonrpc--async-request-1 (list id timer)))) 669 ;; Really send it 670 ;; 671 (jsonrpc-connection-send connection 672 :id id 673 :method method 674 :params params) 675 (puthash id 676 (list (or success-fn 677 (jsonrpc-lambda (&rest _ignored) 678 (jsonrpc--debug 679 connection (list :message "success ignored" 680 :id id)))) 681 (or error-fn 682 (jsonrpc-lambda (&key code message &allow-other-keys) 683 (jsonrpc--debug 684 connection (list 685 :message 686 (format "error ignored, status set (%s)" 687 message) 688 :id id :error code)))) 689 (setq timer (funcall make-timer))) 690 (jsonrpc--request-continuations connection)) 691 (list id timer))) 692 693 (defun jsonrpc--message (format &rest args) 694 "Message out with FORMAT with ARGS." 695 (message "[jsonrpc] %s" (apply #'format format args))) 696 697 (defun jsonrpc--debug (server format &rest args) 698 "Debug message for SERVER with FORMAT and ARGS." 699 (jsonrpc--log-event 700 server (if (stringp format)`(:message ,(format format args)) format))) 701 702 (defun jsonrpc--warn (format &rest args) 703 "Warning message with FORMAT and ARGS." 704 (apply #'jsonrpc--message (concat "(warning) " format) args) 705 (let ((warning-minimum-level :error)) 706 (display-warning 'jsonrpc 707 (apply #'format format args) 708 :warning))) 709 710 (defun jsonrpc--log-event (connection message &optional type) 711 "Log a JSONRPC-related event. 712 CONNECTION is the current connection. MESSAGE is a JSON-like 713 plist. TYPE is a symbol saying if this is a client or server 714 originated." 715 (let ((max (jsonrpc--events-buffer-scrollback-size connection))) 716 (when (or (null max) (cl-plusp max)) 717 (with-current-buffer (jsonrpc-events-buffer connection) 718 (cl-destructuring-bind (&key method id error &allow-other-keys) message 719 (let* ((inhibit-read-only t) 720 (subtype (cond ((and method id) 'request) 721 (method 'notification) 722 (id 'reply) 723 (t 'message))) 724 (type 725 (concat (format "%s" (or type 'internal)) 726 (if type 727 (format "-%s" subtype))))) 728 (goto-char (point-max)) 729 (prog1 730 (let ((msg (format "[%s]%s%s %s:\n%s" 731 type 732 (if id (format " (id:%s)" id) "") 733 (if error " ERROR" "") 734 (current-time-string) 735 (pp-to-string message)))) 736 (when error 737 (setq msg (propertize msg 'face 'error))) 738 (insert-before-markers msg)) 739 ;; Trim the buffer if it's too large 740 (when max 741 (save-excursion 742 (goto-char (point-min)) 743 (while (> (buffer-size) max) 744 (delete-region (point) (progn (forward-line 1) 745 (forward-sexp 1) 746 (forward-line 2) 747 (point))))))))))))) 748 749 ;;;; ChangeLog: 750 751 752 753 (provide 'jsonrpc) 754 ;;; jsonrpc.el ends here