emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

master dceffddbfe7: Jsonrpc: clean up previous change


From: João Távora
Subject: master dceffddbfe7: Jsonrpc: clean up previous change
Date: Fri, 22 Dec 2023 12:19:37 -0500 (EST)

branch: master
commit dceffddbfe78f3f9fd299e736ceb50a00b0fa75e
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>

    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.
---
 lisp/jsonrpc.el | 343 ++++++++++++++++++++++++++++++++------------------------
 1 file changed, 194 insertions(+), 149 deletions(-)

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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]