[elpa] externals/eglot e906d25 14/69: Overhaul JSON and JSRONRPC error handling

[João Távora]

branch: externals/eglot
commit e906d25d6eeb5e75eb7fab8b45d9f88f9a6567c4
Author: João Távora <address@hidden>
Commit: João Távora <address@hidden>

    Overhaul JSON and JSRONRPC error handling
    
    Also fix some bugs.
    
    * jrpc.el (pcase, array): Require it.
    (jrpc--connect): Default error function properly logs error event.
    (jrpc--process-filter): Protect against JSON errors.
    (jrpc--process-receive): Protect against JSONRPC errors.
    (jrpc-reply): Check if both result and error.
    (jrpc--process-send): Ensure json-object-type is plist.
    (jrpc--process-sentinel): Correctly call error handler. Use #'ignore,
    not identity. Use pcase-let instead of cl-dbind
---
 jrpc.el | 102 ++++++++++++++++++++++++++++++++++++++--------------------------
 1 file changed, 60 insertions(+), 42 deletions(-)

diff --git a/jrpc.el b/jrpc.el
index d314c36..eff941a 100644
--- a/jrpc.el
+++ b/jrpc.el
@@ -117,6 +117,8 @@
 (require 'json)
 (require 'subr-x)
 (require 'warnings)
+(require 'pcase)
+(require 'array) ; xor
 
 (defgroup jrpc nil
   "Interaction between JSONRPC endpoints"
@@ -294,17 +296,17 @@ type.
         (insert "\n----------b---y---e---b---y---e----------\n")))
     ;; Cancel outstanding timers
     (maphash (lambda (_id triplet)
-               (cl-destructuring-bind (_success _error timeout) triplet
+               (pcase-let ((`(,_success ,_error ,timeout) triplet))
                  (cancel-timer timeout)))
              (jrpc--request-continuations proc))
     (unwind-protect
         ;; Call all outstanding error handlers
         (maphash (lambda (_id triplet)
-                   (cl-destructuring-bind (_success error _timeout) triplet
-                     (funcall error :code -1 :message (format "Server died"))))
+                   (pcase-let ((`(,_success ,error ,_timeout) triplet))
+                     (funcall error `(:code -1 :message "Server died"))))
                  (jrpc--request-continuations proc))
       (jrpc-message "Server exited with status %s" (process-exit-status proc))
-      (funcall (or (jrpc--on-shutdown proc) #'identity) proc)
+      (funcall (or (jrpc--on-shutdown proc) #'ignore) proc)
       (delete-process proc))))
 
 (defun jrpc--process-filter (proc string)
@@ -352,12 +354,19 @@ type.
                             (save-restriction
                               (narrow-to-region (point) message-end)
                               (let* ((json-object-type 'plist)
-                                     (json-message (json-read)))
-                                ;; Process content in another buffer,
-                                ;; shielding buffer from tamper
-                                ;;
-                                (with-temp-buffer
-                                  (jrpc--process-receive proc json-message))))
+                                     (json-message
+                                      (condition-case-unless-debug oops
+                                          (json-read)
+                                        (error
+                                         (jrpc-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
+                                    (jrpc--process-receive proc 
json-message)))))
                           (goto-char message-end)
                           (delete-region (point-min) (point))
                           (setq expected-bytes nil))))
@@ -412,36 +421,43 @@ is a symbol saying if this is a client or server 
originated."
 
 (defun jrpc--process-receive (proc message)
   "Process MESSAGE from PROC."
-  (cl-destructuring-bind (&key method id error params result _jsonrpc) message
-    (let* ((continuations (and id
-                               (not method)
-                               (gethash id (jrpc--request-continuations 
proc)))))
-      (jrpc-log-event proc message 'server)
-      (when error (setf (jrpc-status proc) `(,error t)))
-      (cond (method
-             (unwind-protect
-                 (funcall (jrpc--dispatcher proc) proc method id params)
-               (unless (or (not id)
-                           (member id (jrpc--server-request-ids proc)))
-                 (jrpc-reply
-                  proc id
-                  :error (jrpc-obj :code -32603 :message "Internal error")))
-               (setf (jrpc--server-request-ids proc)
-                     (delete id (jrpc--server-request-ids proc)))))
-            (continuations
-             (cancel-timer (cl-third continuations))
-             (remhash id (jrpc--request-continuations proc))
-             (if error
-                 (funcall (cl-second continuations) error)
-               (funcall (cl-first continuations) result)))
-            (id
-             (jrpc-warn "Ooops no continuation for id %s" id)))
-      (jrpc--call-deferred proc)
-      (force-mode-line-update t))))
+  (pcase-let ((`(,method ,id ,error ,params ,result)
+               (condition-case-unless-debug oops
+                   (cl-destructuring-bind
+                       (&rest args &key method id error params result _jsonrpc)
+                       message (list method id error params result))
+                 (error (jrpc-warn "Invalid JSONRPC message %s: %s" message
+                                   (cdr oops))
+                        nil)))
+              (continuations))
+    (jrpc-log-event proc message 'server)
+    (when error (setf (jrpc-status proc) `(,error t)))
+    (cond (method
+           (unwind-protect
+               (funcall (jrpc--dispatcher proc) proc method id params)
+             (unless (or (not id)
+                         (member id (jrpc--server-request-ids proc)))
+               (jrpc-reply
+                proc id
+                :error (jrpc-obj :code -32603 :message "Internal error")))
+             (setf (jrpc--server-request-ids proc)
+                   (delete id (jrpc--server-request-ids proc)))))
+          ((setq continuations
+                 (and id (gethash id (jrpc--request-continuations proc))))
+           (let ((timer (nth 2 continuations)))
+             (when timer (cancel-timer timer)))
+           (remhash id (jrpc--request-continuations proc))
+           (if error (funcall (nth 1 continuations) error)
+             (funcall (nth 0 continuations) result)))
+          (id
+           (jrpc-warn "No continuation for id %s" id)))
+    (jrpc--call-deferred proc)
+    (force-mode-line-update t)))
 
 (defun jrpc--process-send (proc message)
   "Send MESSAGE to PROC (ID is optional)."
-  (let ((json (json-encode message)))
+  (let ((json-object-type 'plist)
+        (json (json-encode message)))
     (process-send-string proc (format "Content-Length: %d\r\n\r\n%s"
                                       (string-bytes json)
                                       json))
@@ -550,8 +566,9 @@ Return the request ID, or nil, in case the request was 
deferred."
                    (or error-fn
                        (jrpc-lambda (&key code message &allow-other-keys)
                          (setf (jrpc-status proc) `(,message t))
-                         proc (jrpc-obj :message "error ignored, status set"
-                                        :id id :error code)))
+                         (jrpc-log-event
+                          proc (jrpc-obj :message "error ignored, status set"
+                                         :id id :error code))))
                    (funcall make-timeout))
              (jrpc--request-continuations proc))
     (jrpc--process-send proc (jrpc-obj :jsonrpc "2.0"
@@ -575,7 +592,7 @@ DEFERRED is passed to `jrpc-async-request', which see."
             (jrpc-async-request
              proc method params
              :success-fn (lambda (result) (throw tag `(done ,result)))
-             :error-fn (jrpc-lambda (&key code message &allow-other-keys)
+             :error-fn (jrpc-lambda (&key code message _data)
                          (throw tag `(error ,(format "%s: %s" code message))))
              :timeout-fn (lambda () (throw tag '(error "Timed out")))
              :deferred deferred)
@@ -585,15 +602,16 @@ DEFERRED is passed to `jrpc-async-request', which see."
 
 (cl-defun jrpc-notify (proc method params)
   "Notify PROC of something, don't expect a reply.e"
-  (jrpc--process-send proc (jrpc-obj :jasonrpc  "2.0"
+  (jrpc--process-send proc (jrpc-obj :jsonrpc  "2.0"
                                      :method method
                                      :params params)))
 
 (cl-defun jrpc-reply (proc id &key result error)
   "Reply to PROC's request ID with RESULT or ERROR."
   (push id (jrpc--server-request-ids proc))
+  (unless (xor result error) (jrpc-error "Can't pass both RESULT and ERROR!"))
   (jrpc--process-send
-   proc`(:jasonrpc  "2.0" :id ,id
+   proc `(:jsonrpc  "2.0" :id ,id
                     ,@(when result `(:result ,result))
                     ,@(when error `(:error ,error)))))