From: João Távora Date: Wed, 20 Dec 2023 22:25:28 +0000 (-0600) Subject: Jsonrpc: deal with nested synchronous jsonrpc-request X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=02b99db661861905162a6638349936e784df3189;p=emacs.git Jsonrpc: deal with nested synchronous jsonrpc-request See bug#67945 * lisp/jsonrpc.el (jsonrpc-connection): Add -sync-request-alist (jsonrpc-connection-receive): Rework. (jsonrpc-request): Rework. Pass SYNC-REQUEST to jsonrpc-async-request-1. (jsonrpc--process-sentinel): Simplify. (jsonrpc--schedule): New helper. (jsonrpc--continue): New helper. (jsonrpc--async-request-1): Rework. (jsonrpc--process-sentinel): Also cancel deferred action timers. (Version): Bump to 1.0.21 --- diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 936b17929ec..737351e5d7a 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora ;; Keywords: processes, languages, extensions -;; Version: 1.0.20 +;; Version: 1.0.21 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -87,6 +87,12 @@ :documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\ a saved DEFERRED `async-request' from BUF, to be sent not later\ than TIMER as ID.") + (-sync-request-alist ; bug#67945 + :initform nil + :accessor jsonrpc--sync-request-alist + :documentation "List of ((ID [ANXIOUS...])) where ID refers \ +to a sync `jsonrpc-request' and each ANXIOUS to another completed\ +request that is higher up in the stack but couldn't run.") (-next-request-id :initform 0 :accessor jsonrpc--next-request-id @@ -197,18 +203,22 @@ error and replying to the endpoint with an JSONRPC-error. This variable can be set around calls like `jsonrpc-request' to circumvent that.") -(defun jsonrpc-connection-receive (connection message) - "Process MESSAGE just received from CONNECTION. +(defun jsonrpc-connection-receive (conn message) + "Process MESSAGE just received from CONN. This function will destructure MESSAGE and call the appropriate -dispatcher in CONNECTION." +dispatcher in CONN." (cl-destructuring-bind (&key method id error params result _jsonrpc) - (jsonrpc-convert-from-endpoint connection message) - (jsonrpc--log-event connection message 'server + (jsonrpc-convert-from-endpoint conn message) + (jsonrpc--log-event conn message 'server (cond ((and method id) 'request) (method 'notification) (id 'reply))) - (let (triplet) - (setf (jsonrpc-last-error connection) error) + (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) @@ -217,8 +227,7 @@ dispatcher in CONNECTION." (reply (condition-case-unless-debug _ignore (condition-case oops - `(:result ,(funcall (jsonrpc--request-dispatcher connection) - connection (intern method) params)) + `(:result ,(funcall rdispatcher conn (intern method) params)) (jsonrpc-error `(:error (:code @@ -228,16 +237,18 @@ dispatcher in CONNECTION." "Internal error"))))) (error '(:error (:code -32603 :message "Internal error")))))) - (apply #'jsonrpc--reply connection id method reply))) + (apply #'jsonrpc--reply conn id method reply))) (;; A remote notification method - (funcall (jsonrpc--notification-dispatcher connection) - connection (intern method) params)) - (;; A remote response - (setq triplet (and id (cdr (jsonrpc--remove connection id)))) - (if error (funcall (nth 1 triplet) error) - (funcall (nth 0 triplet) result)))) - (jsonrpc--call-deferred connection)))) + (funcall ndispatcher conn (intern method) params)) + (;; A remote response, but it can't run yet, because there's an + ;; outstanding sync request (bug#67945) + (and id sr-alist (not (eq id (caar sr-alist)))) + (push (cons (jsonrpc--remove conn id) (list result error)) + (cdr (car sr-alist)))) + (;; A remote response that can run + (jsonrpc--continue conn id result error)))) + (jsonrpc--call-deferred conn))) ;;; Contacting the remote endpoint @@ -330,6 +341,7 @@ ignored." (apply #'jsonrpc--async-request-1 connection method params + :sync-request t :success-fn (lambda (result) (unless canceled (throw tag `(done ,result)))) @@ -357,7 +369,10 @@ ignored." ;; to protect against user-quit (C-g) or the ;; `cancel-on-input' case. (pcase-let* ((`(,id ,_) id-and-timer)) - (jsonrpc--remove connection id (list deferred (current-buffer))))))) + (jsonrpc--remove connection id (list deferred (current-buffer))) + ;; We still call `jsonrpc--continue' to run any + ;; "anxious" continuations. + (jsonrpc--continue connection id nil nil))))) (when (eq 'error (car retval)) (signal 'jsonrpc-error (cons @@ -570,17 +585,19 @@ With optional CLEANUP, kill any associated buffers." (let ((inhibit-read-only t)) (insert "\n----------b---y---e---b---y---e----------\n"))) ;; Cancel outstanding timers - (mapc (lambda (_id &rest triplet) - (pcase-let ((`(,_success ,_error ,timeout) triplet)) - (when timeout (cancel-timer timeout)))) + (mapc (lambda (_id _success _error timer) + (when timer (cancel-timer timer))) (jsonrpc--request-continuations connection)) + (maphash (lambda (_ triplet) + (pcase-let ((`(,_ ,timer ,_) triplet)) + (when timer (cancel-timer timer)))) + (jsonrpc--deferred-actions connection)) (process-put proc 'jsonrpc-sentinel-cleanup-started t) (unwind-protect ;; Call all outstanding error handlers - (mapc (lambda (_id &rest triplet) - (pcase-let ((`(,_success ,error ,_timeout) triplet)) - (funcall error '(:code -1 :message "Server died")))) - (jsonrpc--request-continuations connection)) + (mapc (lambda (_id _success error _timer) + (funcall error '(:code -1 :message "Server died"))) + (jsonrpc--request-continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) (delete-process proc) (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) @@ -679,14 +696,50 @@ Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" (setf conts (delete ass conts)) ass))) +(defun jsonrpc--schedule (conn id success-fn error-fn timer) + (push (list id success-fn error-fn timer) + (jsonrpc--request-continuations conn))) + +(defun jsonrpc--continue (conn id result error) + (pcase-let* ((`(,cont-id ,success-fn ,error-fn ,_timer) + (jsonrpc--remove conn id)) + (head (pop (jsonrpc--sync-request-alist conn))) + (anxious (cdr head))) + (cond (anxious + (unless (= (car head) id) + (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 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 + ;; cancelled + )))) + (cl-defun jsonrpc--async-request-1 (connection method params &rest args &key success-fn error-fn timeout-fn (timeout jsonrpc-default-request-timeout) - (deferred nil)) - "Does actual work for `jsonrpc-async-request'. + (deferred nil) + (sync-request nil)) + "Helper for `jsonrpc-request' and `jsonrpc-async-request'. Return a list (ID TIMER). ID is the new request's ID, or nil if the request was deferred. TIMER is a timer object set (or nil, if @@ -696,17 +749,20 @@ TIMEOUT is nil)." (and deferred (gethash (list deferred buf) (jsonrpc--deferred-actions connection)))) (id (or old-id (cl-incf (jsonrpc--next-request-id connection)))) - (make-timer - (lambda ( ) + (maybe-timer + (lambda () (when timeout - (run-with-timer - timeout nil - (lambda () - (jsonrpc--remove connection id (list deferred buf)) - (if timeout-fn (funcall timeout-fn) - (jsonrpc--debug - connection `(:timed-out ,method :id ,id - :params ,params))))))))) + (or timer + (setq + timer + (run-with-timer + timeout nil + (lambda () + (jsonrpc--remove connection id (list deferred buf)) + (if timeout-fn (funcall timeout-fn) + (jsonrpc--debug + connection `(:timed-out ,method :id ,id + :params ,params))))))))))) (when deferred (if (jsonrpc-connection-ready-p connection deferred) ;; Server is ready, we jump below and send it immediately. @@ -720,34 +776,39 @@ TIMEOUT is nil)." (when (buffer-live-p buf) (with-current-buffer buf (save-excursion (goto-char point) - (apply #'jsonrpc-async-request + (apply #'jsonrpc--async-request-1 connection method params args))))) - (or timer (setq timer (funcall make-timer))) id) + (funcall maybe-timer) id) (jsonrpc--deferred-actions connection)) (cl-return-from jsonrpc--async-request-1 (list id timer)))) - ;; Really send it + ;; Really send it thru the wire ;; (jsonrpc-connection-send connection :id id :method method :params params) - (push (cons id - (list (or success-fn - (lambda (&rest _ignored) - (jsonrpc--debug - connection (list :message "success ignored" - :id id)))) - (or error-fn - (jsonrpc-lambda (&key code message &allow-other-keys) - (jsonrpc--debug - connection (list - :message - (format "error ignored, status set (%s)" - message) - :id id :error code)))) - (setq timer (funcall make-timer)))) - (jsonrpc--request-continuations connection)) + ;; Setup some control structures + ;; + (when sync-request + (push (list id) (jsonrpc--sync-request-alist connection))) + + (jsonrpc--schedule connection + id + (or success-fn + (lambda (&rest _ignored) + (jsonrpc--debug + connection (list :message "success ignored" + :id id)))) + (or error-fn + (jsonrpc-lambda (&key code message &allow-other-keys) + (jsonrpc--debug + connection (list + :message + (format "error ignored, status set (%s)" + message) + :id id :error code)))) + (funcall maybe-timer)) (list id timer))) (defun jsonrpc--message (format &rest args)