From: João Távora Date: Fri, 22 Dec 2023 13:44:39 +0000 (-0600) Subject: Jsonrpc: clean up previous change X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=dceffddbfe78f3f9fd299e736ceb50a00b0fa75e;p=emacs.git Jsonrpc: clean up previous change * lisp/jsonrpc.el (jsonrpc-connection): Rework slot names. (jsonrpc-connection-receive): Rework. (jsonrpc--call-deferred): Fix typo. (jsonrpc--process-sentinel) (jsonrpc--remove): Use new slot names. (jsonrpc--continue): Rework. (jsonrpc--async-request-1): Rework. (jsonrpc--event): Remember to remove :jsonrpc-json from foreign-message (jsonrpc--connection-receive): Revamp. (jsonrpc--connection-send) (jsonrpc--connection-reply): Rework. (jsonrpc--log-event): Revamp. (jsonrpc-continuation-count): Use new slot name. --- diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 8951954f842..a1f8892da64 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -68,9 +68,9 @@ :initform nil :accessor jsonrpc-last-error :documentation "Last JSONRPC error message received from endpoint.") - (-request-continuations + (-continuations :initform nil - :accessor jsonrpc--request-continuations + :accessor jsonrpc--continuations :documentation "An alist of request IDs to continuation specs.") (-events-buffer :initform nil @@ -221,7 +221,7 @@ JSONRPC message." (defun jsonrpc-forget-pending-continuations (connection) "Stop waiting for responses from the current JSONRPC CONNECTION." - (setf (jsonrpc--request-continuations connection) nil)) + (setf (jsonrpc--continuations connection) nil)) (defvar jsonrpc-inhibit-debug-on-error nil "Inhibit `debug-on-error' when answering requests. @@ -231,67 +231,96 @@ error and replying to the endpoint with an JSONRPC-error. This variable can be set around calls like `jsonrpc-request' to circumvent that.") -(defun jsonrpc-connection-receive (conn message) - "Process MESSAGE just received from CONN. +(defun jsonrpc-connection-receive (conn foreign-message) + "Process FOREIGN-MESSAGE just received from CONN. This function will destructure MESSAGE and call the appropriate dispatcher in CONN." (cl-destructuring-bind (&rest whole &key method id error params result _jsonrpc) - (jsonrpc-convert-from-endpoint conn message) + (jsonrpc-convert-from-endpoint conn foreign-message) (unwind-protect - (with-slots (last-error - (rdispatcher -request-dispatcher) - (ndispatcher -notification-dispatcher) - (sr-alist -sync-request-alist)) - conn - (setf last-error 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 rdispatcher conn (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 conn id method reply))) - (;; A remote notification - method - (funcall ndispatcher conn (intern method) params)) - (id - (let ((cont - ;; remove the continuation - (jsonrpc--remove conn id))) - (pcase-let ((`(,_ ,method ,_ ,_ ,_) cont)) - (if (keywordp method) - (setq method (substring (symbol-name method) 1))) - (setq whole (plist-put whole :method method))) - (cond (;; A remote response, but it can't run yet, - ;; because there's an outstanding sync request - ;; (bug#67945) - (and sr-alist (not (eq id (caar sr-alist)))) - (push (cons cont (list result error)) - (cdr (car sr-alist)))) - (;; A remote response that can run - (jsonrpc--continue conn id cont result error))))))) - (jsonrpc--run-event-hook - conn 'server - :json (plist-get message :jsonrpc-json) - :kind (cond ((and method id) 'request) - (method 'notification) - (id 'reply)) - :message whole - :foreign-message message) + (let* ((log-plist (list :json (plist-get foreign-message :jsonrpc-json) + :kind (cond ((and method id) 'request) + (method 'notification) + (id 'reply)) + :message whole + :foreign-message foreign-message)) + (response-p (and (null method) id)) + (cont (and response-p (jsonrpc--remove conn id)))) + (cl-remf foreign-message :jsonrpc-json) + ;; Do this pre-processing of the response so we can always + ;; log richer information _before_ any non-local calls + ;; further ahead. Putting the `jsonrpc--event' as + ;; an unwind-form would make us log after the fact. + (when cont + (pcase-let ((`(,_ ,method ,_ ,_ ,_) cont)) + (if (keywordp method) + (setq method (substring (symbol-name method) 1))) + ;; TODO: also set the depth + (setq whole (plist-put whole :method method)))) + + ;; Do the logging + (apply #'jsonrpc--event conn 'server log-plist) + (with-slots (last-error + (rdispatcher -request-dispatcher) + (ndispatcher -notification-dispatcher) + (sr-alist -sync-request-alist)) + conn + (setf last-error error) + (cond + (;; A remote response whose request has been cancelled + ;; (i.e. timeout or C-g) + ;; + (and response-p (null cont)) + (jsonrpc--event + conn 'internal + :log-text + (format "Response to request %s which has been cancelled" + id) + :id id) + ;; TODO: food for thought: this seems to be also where + ;; notifying the server of the cancellation would come + ;; in. + ) + (;; A remote response that can't run yet (bug#67945) + (and response-p + (and sr-alist (not (eq id (caar sr-alist))))) + (jsonrpc--event + conn 'internal + :log-text + (format "anxious continuation to %s can't run, held up by %s" + id + (mapcar #'car sr-alist))) + (push (cons cont (list result error)) + (cdr (car sr-alist)))) + (;; A remote response that can continue now + response-p + (jsonrpc--continue conn id cont result error)) + (;; A remote request + (and method id) + (let* ((debug-on-error (and debug-on-error + (not jsonrpc-inhibit-debug-on-error))) + (reply + (condition-case-unless-debug _ignore + (condition-case oops + `(:result ,(funcall rdispatcher conn (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 conn id method reply))) + (;; A remote notification + method + (funcall ndispatcher conn (intern method) params)) + (t + (jsonrpc--event conn 'internal + :log-text "Malformed message" ))))) (jsonrpc--call-deferred conn)))) @@ -408,15 +437,18 @@ ignored." (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. + ;; In normal operation, continuations for error/success is + ;; handled by `jsonrpc-continue'. Timeouts also remove + ;; the continuation... (pcase-let* ((`(,id ,_) id-and-timer)) - ;; Discard the continuation + ;; ...but we still have to guard against exist explicit + ;; user-quit (C-g) or the `cancel-on-input' case, so + ;; discard the continuation. (jsonrpc--remove connection id (list deferred (current-buffer))) - ;; We still call `jsonrpc--continue' to run any - ;; "anxious" continuations. + ;; ...finally, whatever may have happened to this sync + ;; request, it might have been holding up any outer + ;; "anxious" continuations. The following ensures we + ;; cll them. (jsonrpc--continue connection id))))) (when (eq 'error (car retval)) (signal 'jsonrpc-error @@ -527,8 +559,8 @@ connection object, called when the process dies.") ((stringp method) method) (t (error "[jsonrpc] invalid method %s" method)))))) (let* ((kind (cond ((or result-supplied-p error) 'reply) - (id 'request) - (method 'notification))) + (id 'request) + (method 'notification))) (converted (jsonrpc-convert-to-endpoint connection args kind)) (json (jsonrpc--json-encode converted)) (headers @@ -540,7 +572,7 @@ connection object, called when the process dies.") (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--run-event-hook + (jsonrpc--event connection 'client :json json @@ -624,7 +656,7 @@ With optional CLEANUP, kill any associated buffers." (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--run-event-hook + (jsonrpc--event connection 'internal :log-text (format "re-attempting deferred requests %s" (mapcar (apply-partially #'nth 2) actions))) @@ -641,7 +673,7 @@ With optional CLEANUP, kill any associated buffers." ;; Cancel outstanding timers (mapc (jsonrpc-lambda (_id _method _success-fn _error-fn timer) (when timer (cancel-timer timer))) - (jsonrpc--request-continuations connection)) + (jsonrpc--continuations connection)) (maphash (lambda (_ triplet) (pcase-let ((`(,_ ,timer ,_) triplet)) (when timer (cancel-timer timer)))) @@ -651,7 +683,7 @@ With optional CLEANUP, kill any associated buffers." ;; Call all outstanding error handlers (mapc (jsonrpc-lambda (_id _method _success-fn error-fn _timer) (funcall error-fn '(:code -1 :message "Server died"))) - (jsonrpc--request-continuations connection)) + (jsonrpc--continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) (delete-process proc) (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) @@ -746,48 +778,53 @@ With optional CLEANUP, kill any associated buffers." "Cancel CONN's continuations for ID, including its timer, if it exists. Also cancel \"deferred actions\" if DEFERRED-SPEC. Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" - (with-slots ((conts -request-continuations) (defs -deferred-actions)) conn + (with-slots ((conts -continuations) (defs -deferred-actions)) conn (if deferred-spec (remhash deferred-spec defs)) (when-let ((ass (assq id conts))) (cl-destructuring-bind (_ _ _ _ timer) ass - (cancel-timer timer)) + (cancel-timer timer)) (setf conts (delete ass conts)) ass))) (defun jsonrpc--schedule (conn id method success-fn error-fn timer) (push (list id method success-fn error-fn timer) - (jsonrpc--request-continuations conn))) + (jsonrpc--continuations conn))) (defun jsonrpc--continue (conn id &optional cont result error) (pcase-let* ((`(,cont-id ,_method ,success-fn ,error-fn ,_timer) cont) (head (pop (jsonrpc--sync-request-alist conn))) (anxious (cdr head))) - (cond (anxious - (when (not (= (car head) id)) ; sanity check - (error "internal error: please report this bug")) - ;; If there are "anxious" `jsonrpc-request' continuations - ;; that should already have been run, they should run now. - ;; The main continuation -- if it exists -- should run - ;; before them. This order is important to preserve the - ;; throw to the catch tags in `jsonrpc-request' in - ;; order (bug#67945). - (cl-flet ((later (f arg) (run-at-time 0 nil f arg))) - (when cont-id - (if error (later error-fn error) - (later success-fn result))) - (cl-loop for (acont ares aerr) in anxious - for (_id _method success-fn error-fn) = acont - if aerr do (later error-fn aerr) - else do (later success-fn ares)))) - (cont-id - ;; Else, just run the normal one, with plain funcall. - (if error (funcall error-fn error) - (funcall success-fn result))) - (t - ;; For clarity. This happens if the `jsonrpc-request' was - ;; canceled - )))) + (cond + (anxious + (when (not (= (car head) id)) ; sanity check + (error "internal error: please report this bug")) + ;; If there are "anxious" `jsonrpc-request' continuations + ;; that should already have been run, they should run now. + ;; The main continuation -- if it exists -- should run + ;; before them. This order is important to preserve the + ;; throw to the catch tags in `jsonrpc-request' in + ;; order (bug#67945). + (cl-flet ((later (f arg) (run-at-time 0 nil f arg))) + (when cont-id + (if error (later error-fn error) + (later success-fn result))) + (cl-loop + for (acont ares aerr) in anxious + for (anx-id _method success-fn error-fn) = acont + do (jsonrpc--event + conn 'internal + :log-text (format "anxious continuation to %s running now" anx-id)) + if aerr do (later error-fn aerr) + else do (later success-fn ares)))) + (cont-id + ;; Else, just run the normal one, with plain funcall. + (if error (funcall error-fn error) + (funcall success-fn result))) + (t + ;; For clarity. This happens if the `jsonrpc-request' was + ;; cancelled + )))) (cl-defun jsonrpc--async-request-1 (connection method @@ -817,20 +854,20 @@ TIMEOUT is nil)." timeout nil (lambda () (jsonrpc--remove connection id (list deferred buf)) - (if timeout-fn (funcall timeout-fn) - (jsonrpc--run-event-hook - connection 'internal - :log-text (format "timed-out '%s' (id=%s)" method id) - :id id)))))))))) + (jsonrpc--event + connection 'internal + :log-text (format "timed-out request '%s'" method) + :id id) + (when timeout-fn (funcall timeout-fn)))))))))) (when deferred (if (jsonrpc-connection-ready-p connection deferred) ;; Server is ready, we jump below and send it immediately. (remhash (list deferred buf) (jsonrpc--deferred-actions connection)) ;; Otherwise, save in `jsonrpc--deferred-actions' and exit non-locally (unless old-id - (jsonrpc--run-event-hook + (jsonrpc--event connection 'internal - :log-text (format "deferring '%s' (id=%s)" method id) + :log-text (format "deferring request '%s'" method) :id id)) (puthash (list deferred buf) (list (lambda () @@ -858,13 +895,13 @@ TIMEOUT is nil)." connection id method (or success-fn (lambda (&rest _ignored) - (jsonrpc--run-event-hook + (jsonrpc--event connection 'internal :log-text (format "success ignored") :id id))) (or error-fn (jsonrpc-lambda (&key code message &allow-other-keys) - (jsonrpc--run-event-hook + (jsonrpc--event connection 'internal :log-text (format "error %s ignored: %s ignored" code message) @@ -892,15 +929,20 @@ TIMEOUT is nil)." (apply #'format format args) :warning))) -(cl-defun jsonrpc--run-event-hook (connection - origin - &rest plist - &key _kind _json _message _foreign-message _log-text - &allow-other-keys) +(cl-defun jsonrpc--event (connection + origin + &rest plist + &key _kind _json _message _foreign-message _log-text + &allow-other-keys) (with-current-buffer (jsonrpc-events-buffer connection) (run-hook-wrapped 'jsonrpc-event-hook (lambda (fn) - (apply fn connection origin plist))))) + (condition-case oops + (apply fn connection origin plist) + (error + (jsonrpc--message "event hook '%s' errored (%s). Removing it" + fn oops) + (remove-hook 'jsonrpc-event-hook fn))))))) (defvar jsonrpc-event-hook (list #'jsonrpc--log-event) "Hook run when JSON-RPC events are emitted. @@ -931,9 +973,9 @@ Do not use this hook to write JSON-RPC protocols, use other parts of the API instead.") (cl-defun jsonrpc--log-event (connection origin - &key kind message + &key _kind message foreign-message log-text json - type + type ((:id ref-id)) &allow-other-keys) "Log a JSONRPC-related event. Installed in `jsonrpc-event-hook'." (let* ((props (slot-value connection '-events-buffer-config)) @@ -942,32 +984,35 @@ of the API instead.") (when (or (null max) (cl-plusp max)) (cl-destructuring-bind (&key method id error &allow-other-keys) message (let* ((inhibit-read-only t) - (depth (length (jsonrpc--sync-request-alist connection))) + (depth (length + (jsonrpc--sync-request-alist connection))) + (preamble (format "[jsonrpc] %s[%s]%s " + (pcase type ('error "E") ('debug "D") + (_ (pcase origin + ('internal "i") + (_ "e")))) + (format-time-string "%H:%M:%S.%3N") + (if (eq origin 'internal) + (if ref-id (format " [%s]" ref-id) "") + (format " %s%s %s%s" + (make-string (* 2 depth) ? ) + (pcase origin + ('client "-->") + ('server "<--") + (_ "")) + (or method "") + (if id (format "[%s]" id) ""))))) (msg (cond ((eq format 'full) - (format "[jsonrpc] %s[%s]%s %s\n" - (pcase type ('error "E") ('debug "D") (_ "e")) - (format-time-string "%H:%M:%S.%3N") - (if (eq origin 'internal) - "" - (format " %s%s %s%s" - (make-string (* 2 depth) ? ) - (pcase origin - ('client "-->") - ('server "<--") - (_ "")) - (or method "") - (if id (format "(%s)" id) ""))) - (or json log-text))) + (format "%s%s\n" preamble (or json log-text))) + ((eq format 'short) + (format "%s%s\n" preamble (or log-text ""))) (t - (format "[%s]%s%s %s:\n%s" - (concat (format "%s" (or origin 'internal)) - (if origin (format "-%s" (or kind 'message)))) - (if id (format " (id:%s)" id) "") - (if error " ERROR" "") - (format-time-string "%H:%M:%S.%3N") - (if foreign-message (pp-to-string foreign-message) - log-text)))))) + (format "%s%s" preamble + (or (and foreign-message + (concat "\n" (pp-to-string + foreign-message))) + (concat log-text "\n"))))))) (goto-char (point-max)) ;; XXX: could use `run-at-time' to delay server logs ;; slightly to play nice with verbose servers' stderr. @@ -976,13 +1021,13 @@ of the API instead.") (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))))))))))) + (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. @@ -1092,7 +1137,7 @@ CONNECT-ARGS are passed as additional arguments to (defun jsonrpc-continuation-count (conn) "Number of outstanding continuations for CONN." - (length (jsonrpc--request-continuations conn))) + (length (jsonrpc--continuations conn))) (provide 'jsonrpc) ;;; jsonrpc.el ends here