: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
(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.
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))))
\f
(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
((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
(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
(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)))
;; 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))))
;; 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))
"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
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 ()
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)
(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.
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))
(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.
(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.
(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
projects / emacs.git / commitdiff