procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Jsonrpc: rework fix for bug#60088

Browse source 
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.
This commit is contained in:
João Távora 2023-12-11 00:01:03 +00:00
parent d2f95ea44c
commit 60473c4d90
2 changed files with 32 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
lisp/jsonrpc.el
View file

@ -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

9
test/lisp/jsonrpc-tests.el
View file

@ -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)