Add lisp/jsonrpc.elscratch/add-jsonrpc

* lisp/jsonrpc.el: New file

* test/lisp/jsonrpc-tests.el: New file

1 files changed, 242 insertions, 0 deletions

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