Add lisp/jsonrpc.elscratch/add-jsonrpc

* lisp/jsonrpc.el: New file * test/lisp/jsonrpc-tests.el: New file
author: João Távora <joaotavora@gmail.com> 2018-06-28 13:05:38 +0100
committer: João Távora <joaotavora@gmail.com> 2018-06-29 23:05:19 +0100
commit: 76523866743f39b508e64c34a61af638a4a306b5 (patch)
tree: 2cdda939bf4381b6b970bb3141078416dcd00b89
parent: 08594a975a3d95b1c1eae38af608e487e2edfafc (diff)
download: emacs-scratch/add-jsonrpc.tar.gz
2 files changed, 980 insertions, 0 deletions
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
new file mode 100644
index 00000000000..70044320b44
--- /dev/null
+++ b/lisp/jsonrpc.el
@@ -0,0 +1,738 @@
+;;; jsonrpc.el --- JSON-RPC library                  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: João Távora <joaotavora@gmail.com>
+;; Maintainer: João Távora <joaotavora@gmail.com>
+;; Keywords: processes, languages, extensions
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; (Library originally extracted from eglot.el, an Emacs LSP client)
+;;
+;; This library implements the JSONRPC 2.0 specification as described
+;; in http://www.jsonrpc.org/.  As the name suggests, JSONRPC is a
+;; generic Remote Procedure Call protocol designed around JSON
+;; objects.
+;;
+;; Quoting from the spec: "[JSONRPC] is transport agnostic in that the
+;; concepts can be used within the same process, over sockets, over
+;; http, or in many various message passing environments."
+;;
+;; To model this agnosticism, jsonrpc.el uses objects derived from a
+;; base `jsonrpc-connection' class, which is "abstract" or "virtual"
+;; (in modern OO parlance) and represents the connection to the remote
+;; JSON endpoint.  Around this class we can define two distinct APIs:
+;;
+;; 1) A user interface to the JSONRPC _application_, whereby the
+;; `jsonrpc-connection' object is instantiated and used to communicate
+;; with the remote JSONRPC enpoint.
+;;
+;; In this scenario, the JSONRPC application makes the object using
+;; `make-instance' and initiates contacts to the remove endpoint by
+;; passing it to `jsonrpc-notify', `jsonrpc-request' and
+;; `jsonrpc-async-request'.  For handling remotely initiated contacts,
+;; which generally come in asynchronously, the `make-instance'
+;; invocation should include `:request-dispatcher' and
+;; `:notification-dispatcher' initargs, which are two functions
+;; receiving the connection object, a symbol naming the JSONRPC
+;; method, and a JSONRPC "params" object.
+;;
+;; The function passed as `:request-dispatcher' handles the remote
+;; endpoint's requests, which expect a reply from the local endpoint.
+;; The function may return locally or non-locally (error).  A local
+;; return value should be a JSON object which determines a success
+;; response and is serialized in the JSONRPC "result" object forwarded
+;; to the server.  If, however, it uses the `jsonrpc-error' function
+;; to exit non-locally, this responds to the server with a JSONRPC
+;; "error" object instead, the details of which are filled out with
+;; the arguments with whatever was passed to `jsonrpc-error'.  A
+;; suitable error reponse is also sent to the server if the function
+;; error unexpectedly with any other error that doesn't originate in a
+;; deliberate call to `jsonrpc-error'.
+;;
+;; 2) A inheritance-based interface to the JSONPRPC _transport
+;; implementation_, whereby `jsonrpc-connection' is subclassed so
+;; users of the user interface can communicate with JSONRPC endpoints
+;; using different underlying transport strategies.
+;;
+;; There are mandatory and optional parts to this API.
+;;
+;; For initiating contacts to the endpoint and replying to it, that
+;; subclass of `jsonrpc-connection' must implement
+;; `jsonrpc-connection-send' method.
+;;
+;; Likewise, for handling the three types remote endpoint's contacts
+;; (responses to requests, remotely initiated requests and remotely
+;; initiated notifications) the transport implementation must arrange
+;; for the function `jsonrpc-connection-receive' to be called after
+;; noticing a new JSONRPC message on the wire (whatever that "wire"
+;; may be).
+;;
+;; Finally, and optionally, the `jsonrpc-connection' subclass should
+;; implement `jsonrpc-shutdown' and `jsonrpc-running-p' if these
+;; concepts apply to the transport.
+;;
+;; For convenience, jsonrpc.el comes built-in with a
+;; `jsonrpc-process-connection' transport implementation that can talk
+;; to local subprocesses (through stdin/stdout) and TCP hosts using
+;; sockets.  This uses some basic HTTP-style enveloping headers for
+;; JSON objects sent over the wire.  For an example of an application
+;; using this transport scheme on top of JSONRPC, see the Language
+;; Server Protocol
+;; (https://microsoft.github.io/language-server-protocol/specification).
+;; `jsonrpc-process-connection' also implements `jsonrpc-shutdown',
+;; `jsonrpc-running-p'.
+;;
+;;;; About deferred requests and `jsonrpc-connection-p':
+;;
+;; In the user API.
+;;
+;;;; JSON object format:
+;;
+;; JSON objects are exchanged as keyword-value plists: plists are
+;; handed to the dispatcher functions and, likewise, plists should be
+;; given to `jsonrpc-notify', `jsonrpc-request' and
+;; `jsonrpc-async-request'.
+;;
+;; To facilitate handling plists, this library make liberal use of
+;; cl-lib.el and suggests (but doesn't force) its clients to do the
+;; same.  A macro `jsonrpc-lambda' can be used to create a lambda for
+;; destructuring a JSON-object like in this example:
+;;
+;;  (jsonrpc-async-request
+;;   myproc :frobnicate `(:foo "trix")
+;;   :success-fn (jsonrpc-lambda (&key bar baz &allow-other-keys)
+;;                 (message "Server replied back %s and %s!"
+;;                          bar baz))
+;;   :error-fn (jsonrpc-lambda (&key code message _data)
+;;               (message "Sadly, server reports %s: %s"
+;;                        code message)))
+;;
+;;; Code:
+
+(require 'cl-lib)
+(require 'json)
+(require 'eieio)
+(require 'subr-x)
+(require 'warnings)
+(require 'pcase)
+(require 'ert) ; to escape a `condition-case-unless-debug'
+(require 'array) ; xor
+
+
+;;; Public API
+;;;
+;;;###autoload
+(defclass jsonrpc-connection ()
+  ((name
+    :accessor jsonrpc-name
+    :initarg :name
+    :documentation "A name for the connection")
+   (-request-dispatcher
+    :accessor jsonrpc--request-dispatcher
+    :initform #'ignore
+    :initarg :request-dispatcher
+    :documentation "Dispatcher for remotely invoked requests.")
+   (-notification-dispatcher
+    :accessor jsonrpc--notification-dispatcher
+    :initform #'ignore
+    :initarg :notification-dispatcher
+    :documentation "Dispatcher for remotely invoked notifications.")
+   (last-error
+    :accessor jsonrpc-last-error
+    :documentation "Last JSONRPC error message received from endpoint.")
+   (-request-continuations
+    :initform (make-hash-table)
+    :accessor jsonrpc--request-continuations
+    :documentation "A hash table of request ID to continuation lambdas.")
+   (-events-buffer
+    :accessor jsonrpc--events-buffer
+    :documentation "A buffer pretty-printing the JSON-RPC RPC events")
+   (-deferred-actions
+    :initform (make-hash-table :test #'equal)
+    :accessor jsonrpc--deferred-actions
+    :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.")
+   (-next-request-id
+    :initform 0
+    :accessor jsonrpc--next-request-id
+    :documentation "Next number used for a request"))
+  :documentation "Base class representing a JSONRPC connection.
+The following initargs are accepted:
+
+:NAME (mandatory), a string naming the connection
+
+:REQUEST-DISPATCHER (optional), a function of three
+arguments (CONN METHOD PARAMS) for handling JSONRPC requests.
+CONN is a `jsonrpc-connection' object, method is a symbol, and
+PARAMS is a plist representing a JSON object.  The function is
+expected to return a JSONRPC result, a plist of (:result
+RESULT) or signal an error of type `jsonrpc-error'.
+
+:NOTIFICATION-DISPATCHER (optional), a function of three
+arguments (CONN METHOD PARAMS) for handling JSONRPC
+notifications.  CONN, METHOD and PARAMS are the same as in
+:REQUEST-DISPATCHER.")
+
+;;; API mandatory
+(cl-defgeneric jsonrpc-connection-send (conn &key id method params result error)
+  "Send a JSONRPC message to connection CONN.
+ID, METHOD, PARAMS, RESULT and ERROR. ")
+
+;;; API optional
+(cl-defgeneric jsonrpc-shutdown (conn)
+  "Shutdown the JSONRPC connection CONN.")
+
+;;; API optional
+(cl-defgeneric jsonrpc-running-p (conn)
+  "Tell if the JSONRPC connection CONN is still running.")
+
+;;; API optional
+(cl-defgeneric jsonrpc-connection-ready-p (connection what)
+  "Tell if CONNECTION is ready for WHAT in current buffer.
+If it isn't, a deferrable `jsonrpc-async-request' will be
+deferred to the future.  By default, all connections are ready
+for sending requests immediately."
+  (:method (_s _what)   ;; by default all connections are ready
+           t))
+
+
+;;; Convenience
+;;;
+(cl-defmacro jsonrpc-lambda (cl-lambda-list &body body)
+  (declare (indent 1) (debug (sexp &rest form)))
+  (let ((e (gensym "jsonrpc-lambda-elem")))
+    `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e))))
+
+(defun jsonrpc-events-buffer (connection)
+  "Get or create JSONRPC events buffer for CONNECTION."
+  (let* ((probe (jsonrpc--events-buffer connection))
+         (buffer (or (and (buffer-live-p probe)
+                          probe)
+                     (let ((buffer (get-buffer-create
+                                    (format "*%s events*"
+                                            (jsonrpc-name connection)))))
+                       (with-current-buffer buffer
+                         (buffer-disable-undo)
+                         (read-only-mode t)
+                         (setf (jsonrpc--events-buffer connection) buffer))
+                       buffer))))
+    buffer))
+
+(defun jsonrpc-forget-pending-continuations (connection)
+  "Stop waiting for responses from the current JSONRPC CONNECTION."
+  (clrhash (jsonrpc--request-continuations connection)))
+
+(defun jsonrpc-connection-receive (connection message)
+  "Process MESSAGE just received from CONNECTION.
+This function will destructure MESSAGE and call the appropriate
+dispatcher in CONNECTION."
+  (cl-destructuring-bind (&key method id error params result _jsonrpc)
+      message
+    (let (continuations)
+      (jsonrpc--log-event connection message 'server)
+      (setf (jsonrpc-last-error connection) error)
+      (cond
+       (;; A remote request
+        (and method id)
+        (let* ((debug-on-error (and debug-on-error (not (ert-running-test))))
+               (reply
+                (condition-case-unless-debug _ignore
+                    (condition-case oops
+                        `(:result ,(funcall (jsonrpc--request-dispatcher connection)
+                                            connection (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 connection id reply)))
+       (;; A remote notification
+        method
+        (funcall (jsonrpc--notification-dispatcher connection)
+                 connection (intern method) params))
+       (;; A remote response
+        (setq continuations
+              (and id (gethash id (jsonrpc--request-continuations connection))))
+        (let ((timer (nth 2 continuations)))
+          (when timer (cancel-timer timer)))
+        (remhash id (jsonrpc--request-continuations connection))
+        (if error (funcall (nth 1 continuations) error)
+          (funcall (nth 0 continuations) result)))
+       (;; An abnormal situation
+        id (jsonrpc--warn "No continuation for id %s" id)))
+      (jsonrpc--call-deferred connection))))
+
+
+;;; Contacting the remote endpoint
+;;;
+(defun jsonrpc-error (&rest args)
+  "Error out with FORMAT and ARGS.
+If invoked inside a dispatcher function, this function is suitable
+for replying to the remote endpoint with an error message.
+
+ARGS can be of the form (FORMAT-STRING . MOREARGS) for replying
+with a -32603 error code and a message formed by formatting
+FORMAT-STRING with MOREARGS.
+
+Alternatively ARGS can be plist representing a JSONRPC error
+object, using the keywords `:code', `:message' and `:data'."
+  (if (stringp (car args))
+      (let ((msg
+             (apply #'format-message (car args) (cdr args))))
+        (signal 'jsonrpc-error
+                `(,msg
+                  (jsonrpc-error-code . ,32603)
+                  (jsonrpc-error-message . ,msg))))
+    (cl-destructuring-bind (&key code message data) args
+      (signal 'jsonrpc-error
+              `(,(format "[jsonrpc] error ")
+                (jsonrpc-error-code . ,code)
+                (jsonrpc-error-message . ,message)
+                (jsonrpc-error-data . ,data))))))
+
+(cl-defun jsonrpc-async-request (connection
+                                 method
+                                 params
+                                 &rest args
+                                 &key _success-fn _error-fn
+                                 _timeout-fn
+                                 _timeout _deferred)
+  "Make a request to CONNECTION, expecting a reply, return immediately.
+The JSONRPC request is formed by METHOD, a symbol, and PARAMS a
+JSON object.
+
+The caller can expect SUCCESS-FN or ERROR-FN to be called with a
+JSONRPC `:result' or `:error' object, respectively.  If this
+doesn't happen after TIMEOUT seconds (defaults to
+`jsonrpc-request-timeout'), the caller can expect TIMEOUT-FN to be
+called with no arguments. The default values of SUCCESS-FN,
+ERROR-FN and TIMEOUT-FN simply log the events into
+`jsonrpc-events-buffer'.
+
+If DEFERRED is non-nil, maybe defer the request to a future time
+when the server is thought to be ready according to
+`jsonrpc-connection-ready-p' (which see).  The request might
+never be sent at all, in case it is overridden in the meantime by
+a new request with identical DEFERRED and for the same buffer.
+However, in that situation, the original timeout is kept.
+
+Returns nil."
+  (apply #'jsonrpc--async-request-1 connection method params args)
+  nil)
+
+(cl-defun jsonrpc-request (connection method params &key deferred timeout)
+  "Make a request to CONNECTION, wait for a reply.
+Like `jsonrpc-async-request' for CONNECTION, METHOD and PARAMS, but
+synchronous, i.e. doesn't exit until anything
+interesting (success, error or timeout) happens.  Furthermore,
+only exit locally (and return the JSONRPC result object) if the
+request is successful, otherwise exit non-locally with an error
+of type `jsonrpc-error'.
+
+DEFERRED is passed to `jsonrpc-async-request', which see."
+  (let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer
+         (retval
+          (unwind-protect ; protect against user-quit, for example
+              (catch tag
+                (setq
+                 id-and-timer
+                 (jsonrpc--async-request-1
+                  connection method params
+                  :success-fn (lambda (result) (throw tag `(done ,result)))
+                  :error-fn
+                  (jsonrpc-lambda
+                      (&key code message data)
+                    (throw tag `(error (jsonrpc-error-code . ,code)
+                                       (jsonrpc-error-message . ,message)
+                                       (jsonrpc-error-data . ,data))))
+                  :timeout-fn
+                  (lambda ()
+                    (throw tag '(error (jsonrpc-error-message . "Timed out"))))
+                  :deferred deferred
+                  :timeout timeout))
+                (while t (accept-process-output nil 30)))
+            (pcase-let* ((`(,id ,timer) id-and-timer))
+              (remhash id (jsonrpc--request-continuations connection))
+              (remhash (list deferred (current-buffer))
+                       (jsonrpc--deferred-actions connection))
+              (when timer (cancel-timer timer))))))
+    (when (eq 'error (car retval))
+      (signal 'jsonrpc-error
+              (cons
+               (format "request id=%s failed:" (car id-and-timer))
+               (cdr retval))))
+    (cadr retval)))
+
+(cl-defun jsonrpc-notify (connection method params)
+  "Notify CONNECTION of something, don't expect a reply."
+  (jsonrpc-connection-send connection
+                           :method method
+                           :params params))
+
+(defconst jrpc-default-request-timeout 10
+  "Time in seconds before timing out a JSONRPC request.")
+
+
+;;; Specfic to `jsonrpc-process-connection'
+;;;
+;;;###autoload
+(defclass jsonrpc-process-connection (jsonrpc-connection)
+  ((-process
+    :initarg :process :accessor jsonrpc--process
+    :documentation "Process object wrapped by the this connection.")
+   (-expected-bytes
+    :accessor jsonrpc--expected-bytes
+    :documentation "How many bytes declared by server")
+   (-on-shutdown
+    :accessor jsonrpc--on-shutdown
+    :initform #'ignore
+    :initarg :on-shutdown
+    :documentation "Function run when the process dies."))
+  :documentation "A JSONRPC connection over an Emacs process.
+The following initargs are accepted:
+
+:PROCESS (mandatory), a live running Emacs process object or a
+function of no arguments producing one such object.  The process
+represents either a pipe connection to locally running process or
+a stream connection to a network host.  The remote endpoint is
+expected to understand JSONRPC messages with basic HTTP-style
+enveloping headers such as \"Content-Length:\".
+
+:ON-SHUTDOWN (optional), a function of one argument, the
+connection object, called when the process dies .")
+
+(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots)
+  (cl-call-next-method)
+  (let* ((proc (plist-get slots :process))
+         (proc (if (functionp proc) (funcall proc) proc))
+         (buffer (get-buffer-create (format "*%s output*" (process-name proc))))
+         (stderr (get-buffer-create (format "*%s stderr*" (process-name proc)))))
+    (setf (jsonrpc--process conn) proc)
+    (set-process-buffer proc buffer)
+    (process-put proc 'jsonrpc-stderr stderr)
+    (set-process-filter proc #'jsonrpc--process-filter)
+    (set-process-sentinel proc #'jsonrpc--process-sentinel)
+    (with-current-buffer (process-buffer proc)
+      (set-marker (process-mark proc) (point-min))
+      (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc))
+    (process-put proc 'jsonrpc-connection conn)))
+
+(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
+                                       &rest args
+                                       &key
+                                       _id
+                                       method
+                                       _params
+                                       _result
+                                       _error
+                                       _partial)
+  "Send MESSAGE, a JSON object, to CONNECTION."
+  (when method
+    (plist-put args :method
+               (cond ((keywordp method) (substring (symbol-name method) 1))
+                     ((and method (symbolp method)) (symbol-name method)))))
+  (let* ( (message `(:jsonrpc "2.0" ,@args))
+          (json (jsonrpc--json-encode message))
+          (headers
+           `(("Content-Length" . ,(format "%d" (string-bytes json)))
+             ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8")
+             )))
+    (process-send-string
+     (jsonrpc--process connection)
+     (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--log-event connection message 'client)))
+
+(defun jsonrpc-process-type (conn)
+  "Return the `process-type' of JSONRPC connection CONN."
+  (process-type (jsonrpc--process conn)))
+
+(cl-defmethod jsonrpc-running-p ((conn jsonrpc-process-connection))
+  "Return non-nil if JSONRPC connection CONN is running."
+  (process-live-p (jsonrpc--process conn)))
+
+(cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection))
+  "Shutdown the JSONRPC connection CONN."
+  (cl-loop
+   with proc = (jsonrpc--process conn)
+   do
+   (delete-process proc)
+   (accept-process-output nil 0.1)
+   while (not (process-get proc 'jsonrpc-sentinel-done))
+   do (jsonrpc--warn
+       "Sentinel for %s still hasn't run,  deleting it!" proc)))
+
+(defun jsonrpc-stderr-buffer (conn)
+  "Get CONN's standard error buffer, if any."
+  (process-get (jsonrpc--process conn) 'jsonrpc-stderr))
+
+
+;;; Private stuff
+;;;
+(define-error 'jsonrpc-error "jsonrpc-error")
+
+(defun jsonrpc--json-read ()
+  "Read JSON object in buffer, move point to end of buffer."
+  ;; TODO: I guess we can make these macros if/when jsonrpc.el
+  ;; goes into Emacs core.
+  (cond ((fboundp 'json-parse-buffer) (json-parse-buffer
+                                       :object-type 'plist
+                                       :null-object nil
+                                       :false-object :json-false))
+        (t                            (let ((json-object-type 'plist))
+                                        (json-read)))))
+
+(defun jsonrpc--json-encode (object)
+  "Encode OBJECT into a JSON string."
+  (cond ((fboundp 'json-serialize) (json-serialize
+                                    object
+                                    :false-object :json-false
+                                    :null-object nil))
+        (t                         (let ((json-false :json-false)
+                                         (json-null nil))
+                                     (json-encode object)))))
+
+(cl-defun jsonrpc--reply (connection id &key (result nil result-supplied-p) error)
+  "Reply to CONNECTION's request ID with RESULT or ERROR."
+  (jsonrpc-connection-send connection :id id :result result :error error))
+
+(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--debug connection `(:maybe-run-deferred ,(mapcar #'caddr actions)))
+    (mapc #'funcall (mapcar #'car actions))))
+
+(defun jsonrpc--process-sentinel (proc change)
+  "Called when PROC undergoes CHANGE."
+  (let ((connection (process-get proc 'jsonrpc-connection)))
+    (jsonrpc--debug connection `(:message "Connection state changed" :change ,change))
+    (when (not (process-live-p proc))
+      (with-current-buffer (jsonrpc-events-buffer connection)
+        (let ((inhibit-read-only t))
+          (insert "\n----------b---y---e---b---y---e----------\n")))
+      ;; Cancel outstanding timers
+      (maphash (lambda (_id triplet)
+                 (pcase-let ((`(,_success ,_error ,timeout) triplet))
+                   (when timeout (cancel-timer timeout))))
+               (jsonrpc--request-continuations connection))
+      (unwind-protect
+          ;; Call all outstanding error handlers
+          (maphash (lambda (_id triplet)
+                     (pcase-let ((`(,_success ,error ,_timeout) triplet))
+                       (funcall error `(:code -1 :message "Server died"))))
+                   (jsonrpc--request-continuations connection))
+        (jsonrpc--message "Server exited with status %s" (process-exit-status proc))
+        (process-put proc 'jsonrpc-sentinel-done t)
+        (delete-process proc)
+        (funcall (jsonrpc--on-shutdown connection) connection)))))
+
+(defun jsonrpc--process-filter (proc string)
+  "Called when new data STRING has arrived for PROC."
+  (when (buffer-live-p (process-buffer proc))
+    (with-current-buffer (process-buffer proc)
+      (let* ((inhibit-read-only t)
+             (connection (process-get proc 'jsonrpc-connection))
+             (expected-bytes (jsonrpc--expected-bytes connection)))
+        ;; Insert the text, advancing the process marker.
+        ;;
+        (save-excursion
+          (goto-char (process-mark proc))
+          (insert string)
+          (set-marker (process-mark proc) (point)))
+        ;; Loop (more than one message might have arrived)
+        ;;
+        (unwind-protect
+            (let (done)
+              (while (not done)
+                (cond
+                 ((not expected-bytes)
+                  ;; Starting a new message
+                  ;;
+                  (setq expected-bytes
+                        (and (search-forward-regexp
+                              "\\(?:.*: .*\r\n\\)*Content-Length: \
+*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
+                              (+ (point) 100)
+                              t)
+                             (string-to-number (match-string 1))))
+                  (unless expected-bytes
+                    (setq done :waiting-for-new-message)))
+                 (t
+                  ;; Attempt to complete a message body
+                  ;;
+                  (let ((available-bytes (- (position-bytes (process-mark proc))
+                                            (position-bytes (point)))))
+                    (cond
+                     ((>= available-bytes
+                          expected-bytes)
+                      (let* ((message-end (byte-to-position
+                                           (+ (position-bytes (point))
+                                              expected-bytes))))
+                        (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)))))
+                          (goto-char message-end)
+                          (delete-region (point-min) (point))
+                          (setq expected-bytes nil))))
+                     (t
+                      ;; Message is still incomplete
+                      ;;
+                      (setq done :waiting-for-more-bytes-in-this-message))))))))
+          ;; Saved parsing state for next visit to this filter
+          ;;
+          (setf (jsonrpc--expected-bytes connection) expected-bytes))))))
+
+(cl-defun jsonrpc--async-request-1 (connection
+                                    method
+                                    params
+                                    &rest args
+                                    &key success-fn error-fn timeout-fn
+                                    (timeout jrpc-default-request-timeout)
+                                    (deferred nil))
+  "Does actual work for `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
+TIMEOUT is nil)."
+  (pcase-let* ((buf (current-buffer)) (point (point))
+               (`(,_ ,timer ,old-id)
+                (and deferred (gethash (list deferred buf)
+                                       (jsonrpc--deferred-actions connection))))
+               (id (or old-id (cl-incf (jsonrpc--next-request-id connection))))
+               (make-timer
+                (lambda ( )
+                  (when timeout
+                    (run-with-timer
+                     timeout nil
+                     (lambda ()
+                       (remhash id (jsonrpc--request-continuations connection))
+                       (remhash (list deferred buf)
+                                (jsonrpc--deferred-actions connection))
+                       (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.
+          (remhash (list deferred buf) (jsonrpc--deferred-actions connection))
+        ;; Otherwise, save in `eglot--deferred-actions' and exit non-locally
+        (unless old-id
+          (jsonrpc--debug connection `(:deferring ,method :id ,id :params
+                                                  ,params)))
+        (puthash (list deferred buf)
+                 (list (lambda ()
+                         (when (buffer-live-p buf)
+                           (with-current-buffer buf
+                             (save-excursion (goto-char point)
+                                             (apply #'jsonrpc-async-request
+                                                    connection
+                                                    method params args)))))
+                       (or timer (setq timer (funcall make-timer))) id)
+                 (jsonrpc--deferred-actions connection))
+        (cl-return-from jsonrpc--async-request-1 (list id timer))))
+    ;; Really send it
+    ;;
+    (jsonrpc-connection-send connection
+                             :id id
+                             :method method
+                             :params params)
+    (puthash id
+             (list (or success-fn
+                       (jsonrpc-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))
+    (list id timer)))
+
+(defun jsonrpc--message (format &rest args)
+  "Message out with FORMAT with ARGS."
+  (message "[jsonrpc] %s" (apply #'format format args)))
+
+(defun jsonrpc--debug (server format &rest args)
+  "Debug message for SERVER with FORMAT and ARGS."
+  (jsonrpc--log-event
+   server (if (stringp format)`(:message ,(format format args)) format)))
+
+(defun jsonrpc--warn (format &rest args)
+  "Warning message with FORMAT and ARGS."
+  (apply #'jsonrpc--message (concat "(warning) " format) args)
+  (let ((warning-minimum-level :error))
+    (display-warning 'jsonrpc
+                     (apply #'format format args)
+                     :warning)))
+
+(defun jsonrpc--log-event (connection message &optional type)
+  "Log a JSONRPC-related event.
+CONNECTION is the current connection.  MESSAGE is a JSON-like
+plist.  TYPE is a symbol saying if this is a client or server
+originated."
+  (with-current-buffer (jsonrpc-events-buffer connection)
+    (cl-destructuring-bind (&key method id error &allow-other-keys) message
+      (let* ((inhibit-read-only t)
+             (subtype (cond ((and method id)       'request)
+                            (method                'notification)
+                            (id                    'reply)
+                            (t                     'message)))
+             (type
+              (concat (format "%s" (or type 'internal))
+                      (if type
+                          (format "-%s" subtype)))))
+        (goto-char (point-max))
+        (let ((msg (format "%s%s%s %s:\n%s\n"
+                           type
+                           (if id (format " (id:%s)" id) "")
+                           (if error " ERROR" "")
+                           (current-time-string)
+                           (pp-to-string message))))
+          (when error
+            (setq msg (propertize msg 'face 'error)))
+          (insert-before-markers msg))))))
+
+(provide 'jsonrpc)
+;;; jsonrpc.el ends here
diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el
new file mode 100644
index 00000000000..bfdb513ada4
--- /dev/null
+++ b/test/lisp/jsonrpc-tests.el
@@ -0,0 +1,242 @@
+;;; jsonrpc-tests.el --- tests for jsonrpc.el        -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: João Távora <joaotavora@gmail.com>
+;; Maintainer: João Távora <joaotavora@gmail.com>
+;; Keywords: tests
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; About "deferred" tests, `jsonrpc--test-client' has a flag that we
+;; test this flag in the this `jsonrpc-connection-ready-p' API method.
+;; It holds any `jsonrpc-request's and `jsonrpc-async-request's
+;; explicitly passed `:deferred'.  After clearing the flag, the held
+;; requests are actually sent to the server in the next opportunity
+;; (when receiving or sending something to the server).
+
+;;; Code:
+
+(require 'ert)
+(require 'jsonrpc)
+(require 'eieio)
+
+(defclass jsonrpc--test-endpoint (jsonrpc-process-connection)
+  ((scp :accessor jsonrpc--shutdown-complete-p)))
+
+(defclass jsonrpc--test-client (jsonrpc--test-endpoint)
+  ((hold-deferred :initform t :accessor jsonrpc--hold-deferred)))
+
+(cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body)
+  (declare (indent 1) (debug t))
+  (let ((server (gensym "server-")) (listen-server (gensym "listen-server-")))
+    `(let* (,server
+            (,listen-server
+             (make-network-process
+              :name "Emacs RPC server" :server t :host "localhost"
+              :service 0
+              :log (lambda (_server client _message)
+                     (setq ,server
+                           (make-instance
+                            'jsonrpc--test-endpoint
+                            :name (process-name client)
+                            :process client
+                            :request-dispatcher
+                            (lambda (_endpoint method params)
+                              (unless (memq method '(+ - * / vconcat append
+                                                       sit-for ignore))
+                                (signal 'jsonrpc-error
+                                        `((jsonrpc-error-message
+                                           . "Sorry, this isn't allowed")
+                                          (jsonrpc-error-code . -32601))))
+                              (apply method (append params nil)))
+                            :on-shutdown
+                            (lambda (conn)
+                              (setf (jsonrpc--shutdown-complete-p conn) t)))))))
+            (,endpoint-sym (make-instance
+                            'jsonrpc--test-client
+                            "Emacs RPC client"
+                            :process
+                            (open-network-stream "JSONRPC test tcp endpoint"
+                                                 nil "localhost"
+                                                 (process-contact ,listen-server
+                                                                  :service))
+                            :on-shutdown
+                            (lambda (conn)
+                              (setf (jsonrpc--shutdown-complete-p conn) t)))))
+       (unwind-protect
+           (progn
+             (cl-assert ,endpoint-sym)
+             ,@body
+             (kill-buffer (jsonrpc--events-buffer ,endpoint-sym))
+             (when ,server
+               (kill-buffer (jsonrpc--events-buffer ,server))))
+         (unwind-protect
+             (jsonrpc-shutdown ,endpoint-sym)
+           (unwind-protect
+               (jsonrpc-shutdown ,server)
+             (cl-loop do (delete-process ,listen-server)
+                      while (progn (accept-process-output nil 0.1)
+                                   (process-live-p ,listen-server))
+                      do (jsonrpc--message
+                          "test listen-server is still running, waiting"))))))))
+
+(ert-deftest returns-3 ()
+  "A basic test for adding two numbers in our test RPC."
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    (should (= 3 (jsonrpc-request conn '+ [1 2])))))
+
+(ert-deftest errors-with--32601 ()
+  "Errors with -32601"
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    (condition-case err
+        (progn
+          (jsonrpc-request conn 'delete-directory "~/tmp")
+          (ert-fail "A `jsonrpc-error' should have been signalled!"))
+      (jsonrpc-error
+       (should (= -32601 (cdr (assoc 'jsonrpc-error-code (cdr err)))))))))
+
+(ert-deftest signals-an--32603-JSONRPC-error ()
+  "Signals an -32603 JSONRPC error."
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    (condition-case err
+        (progn
+          (jsonrpc-request conn '+ ["a" 2])
+          (ert-fail "A `jsonrpc-error' should have been signalled!"))
+      (jsonrpc-error
+       (should (= -32603 (cdr (assoc 'jsonrpc-error-code (cdr err)))))))))
+
+(ert-deftest times-out ()
+  "Request for 3-sec sit-for with 1-sec timeout times out."
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    (should-error
+     (jsonrpc-request conn 'sit-for [3] :timeout 1))))
+
+(ert-deftest doesnt-time-out ()
+  :tags '(:expensive-test)
+  "Request for 1-sec sit-for with 2-sec timeout succeeds."
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    (jsonrpc-request conn 'sit-for [1] :timeout 2)))
+
+(ert-deftest stretching-it-but-works ()
+  "Vector of numbers or vector of vector of numbers are serialized."
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    ;; (vconcat [1 2 3] [3 4 5]) => [1 2 3 3 4 5] which can be
+    ;; serialized.
+    (should (equal
+             [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)
+       (or (not (string-match "deferred" what))
+           (not (jsonrpc--hold-deferred conn)))))
+
+(ert-deftest deferred-action-toolate ()
+  :tags '(:expensive-test)
+  "Deferred request fails because noone clears the flag."
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    (should-error
+     (jsonrpc-request conn '+ [1 2]
+                      :deferred "deferred-testing" :timeout 0.5)
+     :type 'jsonrpc-error)
+    (should
+     (= 3 (jsonrpc-request conn '+ [1 2]
+                           :timeout 0.5)))))
+
+(ert-deftest deferred-action-intime ()
+  :tags '(:expensive-test)
+  "Deferred request barely makes it after event clears a flag."
+  ;; Send an async request, which returns immediately. However the
+  ;; success fun which sets the flag only runs after some time.
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    (jsonrpc-async-request conn
+                           'sit-for [0.5]
+                           :success-fn
+                           (lambda (_result)
+                             (setf (jsonrpc--hold-deferred conn) nil)))
+    ;; Now wait for an answer to this request, which should be sent as
+    ;; soon as the previous one is answered.
+    (should
+     (= 3 (jsonrpc-request conn '+ [1 2]
+                           :deferred "deferred"
+                           :timeout 1)))))
+
+(ert-deftest deferred-action-complex-tests ()
+  :tags '(:expensive-test)
+  "Test a more complex situation with deferred requests."
+  (jsonrpc--with-emacsrpc-fixture (conn)
+    (let (n-deferred-1
+          n-deferred-2
+          second-deferred-went-through-p)
+      ;; This returns immediately
+      (jsonrpc-async-request
+       conn
+       'sit-for [0.1]
+       :success-fn
+       (lambda (_result)
+         ;; this only gets runs after the "first deferred" is stashed.
+         (setq n-deferred-1
+               (hash-table-count (jsonrpc--deferred-actions conn)))))
+      (should-error
+       ;; This stashes the request and waits. It will error because
+       ;; no-one clears the "hold deferred" flag.
+       (jsonrpc-request conn 'ignore ["first deferred"]
+                        :deferred "first deferred"
+                        :timeout 0.5)
+       :type 'jsonrpc-error)
+      ;; The error means the deferred actions stash is now empty
+      (should (zerop (hash-table-count (jsonrpc--deferred-actions conn))))
+      ;; Again, this returns immediately.
+      (jsonrpc-async-request
+       conn
+       'sit-for [0.1]
+       :success-fn
+       (lambda (_result)
+         ;; This gets run while "third deferred" below is waiting for
+         ;; a reply.  Notice that we clear the flag in time here.
+         (setq n-deferred-2 (hash-table-count (jsonrpc--deferred-actions conn)))
+         (setf (jsonrpc--hold-deferred conn) nil)))
+      ;; This again stashes a request and returns immediately.
+      (jsonrpc-async-request conn 'ignore ["second deferred"]
+                             :deferred "second deferred"
+                             :timeout 1
+                             :success-fn
+                             (lambda (_result)
+                               (setq second-deferred-went-through-p t)))
+      ;; And this also stashes a request, but waits.  Eventually the
+      ;; flag is cleared in time and both requests go through.
+      (jsonrpc-request conn 'ignore ["third deferred"]
+                       :deferred "third deferred"
+                       :timeout 1)
+      (should second-deferred-went-through-p)
+      (should (eq 1 n-deferred-1))
+      (should (eq 2 n-deferred-2))
+      (should (eq 0 (hash-table-count (jsonrpc--deferred-actions conn)))))))
+
+
+
+(provide 'jsonrpc-tests)
+;;; jsonrpc-tests.el ends here
author	João Távora <joaotavora@gmail.com>	2018-06-28 13:05:38 +0100
committer	João Távora <joaotavora@gmail.com>	2018-06-29 23:05:19 +0100
commit	76523866743f39b508e64c34a61af638a4a306b5 (patch)
tree	2cdda939bf4381b6b970bb3141078416dcd00b89
parent	08594a975a3d95b1c1eae38af608e487e2edfafc (diff)
download	emacs-scratch/add-jsonrpc.tar.gz