From: João Távora Date: Mon, 11 Dec 2023 00:01:03 +0000 (+0000) Subject: Jsonrpc: rework fix for bug#60088 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=60473c4d90a6cdce3f06e183809f5be440dd8797;p=emacs.git Jsonrpc: rework fix for bug#60088 Try to decouple receiving text and processing messages in the event loop. This should allow for requests within requests in both Eglot and the Dape extension (https://github.com/svaante/dape). jsonrpc-connection-receive is now called from timers after the process filter finished. Because of this, a detail is that any serialization errors are now thrown from timers instead of the synchronous process filter, and there's no good way to test this in ert, so a test has been deleted. * lisp/jsonrpc.el (jsonrpc--process-filter): Rework. * test/lisp/jsonrpc-tests.el (json-el-cant-serialize-this): Delete test. --- diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 67243fd49e3..9cb6b90f733 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -564,27 +564,12 @@ With optional CLEANUP, kill any associated buffers." (delete-process proc) (funcall (jsonrpc--on-shutdown connection) connection))))) -(defvar jsonrpc--in-process-filter nil - "Non-nil if inside `jsonrpc--process-filter'.") - (cl-defun jsonrpc--process-filter (proc string) "Called when new data STRING has arrived for PROC." - (when jsonrpc--in-process-filter - ;; Problematic recursive process filters may happen if - ;; `jsonrpc--connection-receive', called by us, eventually calls - ;; client code which calls `process-send-string' (which see) to, - ;; say send a follow-up message. If that happens to writes enough - ;; bytes for pending output to be received, we will lose JSONRPC - ;; messages. In that case, remove recursiveness by re-scheduling - ;; ourselves to run from within a timer as soon as possible - ;; (bug#60088) - (run-at-time 0 nil #'jsonrpc--process-filter proc string) - (cl-return-from jsonrpc--process-filter)) (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) - (let* ((jsonrpc--in-process-filter t) - (connection (process-get proc 'jsonrpc-connection)) - (expected-bytes (jsonrpc--expected-bytes connection))) + (let* ((conn (process-get proc 'jsonrpc-connection)) + (expected-bytes (jsonrpc--expected-bytes conn))) ;; Insert the text, advancing the process marker. ;; (save-excursion @@ -619,24 +604,24 @@ With optional CLEANUP, kill any associated buffers." expected-bytes) (let* ((message-end (byte-to-position (+ (position-bytes (point)) - expected-bytes)))) + expected-bytes))) + message + ) (unwind-protect (save-restriction (narrow-to-region (point) message-end) - (let* ((json-message - (condition-case-unless-debug oops - (jsonrpc--json-read) - (error - (jsonrpc--warn "Invalid JSON: %s %s" - (cdr oops) (buffer-string)) - nil)))) - (when json-message - ;; Process content in another - ;; buffer, shielding proc buffer from - ;; tamper - (with-temp-buffer - (jsonrpc-connection-receive connection - json-message))))) + (setq message + (condition-case-unless-debug oops + (jsonrpc--json-read) + (error + (jsonrpc--warn "Invalid JSON: %s %s" + (cdr oops) (buffer-string)) + nil))) + (when message + (process-put proc 'jsonrpc-mqueue + (nconc (process-get proc + 'jsonrpc-mqueue) + (list message))))) (goto-char message-end) (let ((inhibit-read-only t)) (delete-region (point-min) (point))) @@ -645,9 +630,21 @@ With optional CLEANUP, kill any associated buffers." ;; Message is still incomplete ;; (setq done :waiting-for-more-bytes-in-this-message)))))))) - ;; Saved parsing state for next visit to this filter + ;; Saved parsing state for next visit to this filter, which + ;; may well be a recursive one stemming from the tail call + ;; to `jsonrpc-connection-receive' below (bug#60088). ;; - (setf (jsonrpc--expected-bytes connection) expected-bytes)))))) + (setf (jsonrpc--expected-bytes conn) expected-bytes) + ;; Now, time to notify user code of one or more messages in + ;; order. Very often `jsonrpc-connection-receive' will exit + ;; non-locally (typically the reply to a request), so do + ;; this all this processing in top-level loops timer. + (cl-loop + for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg + do (run-at-time 0 nil + (lambda (m) (with-temp-buffer + (jsonrpc-connection-receive conn m))) + msg))))))) (cl-defun jsonrpc--async-request-1 (connection method diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el index 85ac96a931c..5c3b694194f 100644 --- a/test/lisp/jsonrpc-tests.el +++ b/test/lisp/jsonrpc-tests.el @@ -103,6 +103,7 @@ (process-get listen-server 'handlers)))))))) (cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body) + (declare (indent 1)) `(jsonrpc--call-with-emacsrpc-fixture (lambda (,endpoint-sym) ,@body))) (ert-deftest returns-3 () @@ -151,14 +152,6 @@ [1 2 3 3 4 5] (jsonrpc-request conn 'vconcat [[1 2 3] [3 4 5]]))))) -(ert-deftest json-el-cant-serialize-this () - "Can't serialize a response that is half-vector/half-list." - (jsonrpc--with-emacsrpc-fixture (conn) - (should-error - ;; (append [1 2 3] [3 4 5]) => (1 2 3 . [3 4 5]), which can't be - ;; serialized - (jsonrpc-request conn 'append [[1 2 3] [3 4 5]])))) - (cl-defmethod jsonrpc-connection-ready-p ((conn jsonrpc--test-client) what) (and (cl-call-next-method)