mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-21 06:55:39 +00:00
258 lines
10 KiB
EmacsLisp
258 lines
10 KiB
EmacsLisp
;;; jsonrpc-tests.el --- tests for jsonrpc.el -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2018-2024 Free Software Foundation, Inc.
|
|
|
|
;; Author: João Távora <joaotavora@gmail.com>
|
|
;; Keywords: tests
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs 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.
|
|
|
|
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; About "deferred" tests, `jsonrpc--test-client' has a flag that we
|
|
;; test in its `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)))
|
|
|
|
(defun jsonrpc--call-with-emacsrpc-fixture (fn)
|
|
"Do work for `jsonrpc--with-emacsrpc-fixture'. Call FN."
|
|
(let* (listen-server endpoint)
|
|
(unwind-protect
|
|
(progn
|
|
(setq listen-server
|
|
(make-network-process
|
|
:name "Emacs RPC server" :server t :host "localhost"
|
|
:service (if (version<= emacs-version "26.1")
|
|
44444
|
|
;; 26.1 can automatically find ports if
|
|
;; one passes 0 here.
|
|
0)
|
|
:log (lambda (listen-server client _message)
|
|
(push
|
|
(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)))
|
|
(process-get listen-server 'handlers)))))
|
|
(setq endpoint
|
|
(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))))
|
|
(funcall fn endpoint))
|
|
(unwind-protect
|
|
(when endpoint
|
|
(kill-buffer (jsonrpc--events-buffer endpoint))
|
|
(jsonrpc-shutdown endpoint))
|
|
(when listen-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"))
|
|
(cl-loop for handler in (process-get listen-server 'handlers)
|
|
do (ignore-errors (jsonrpc-shutdown handler)))
|
|
(mapc #'kill-buffer
|
|
(mapcar #'jsonrpc--events-buffer
|
|
(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 ()
|
|
"A basic test for adding two numbers in our test RPC."
|
|
(skip-when (eq system-type 'windows-nt))
|
|
(jsonrpc--with-emacsrpc-fixture (conn)
|
|
(should (= 3 (jsonrpc-request conn '+ [1 2])))))
|
|
|
|
(ert-deftest errors-with--32601 ()
|
|
"Errors with -32601"
|
|
(skip-when (eq system-type 'windows-nt))
|
|
(jsonrpc--with-emacsrpc-fixture (conn)
|
|
(condition-case err
|
|
(progn
|
|
(jsonrpc-request conn 'delete-directory "~/tmp")
|
|
(ert-fail "A `jsonrpc-error' should have been signaled!"))
|
|
(jsonrpc-error
|
|
(should (= -32601 (cdr (assoc 'jsonrpc-error-code (cdr err)))))))))
|
|
|
|
(ert-deftest signals-an--32603-JSONRPC-error ()
|
|
"Signals an -32603 JSONRPC error."
|
|
(skip-when (eq system-type 'windows-nt))
|
|
(jsonrpc--with-emacsrpc-fixture (conn)
|
|
(condition-case err
|
|
(let ((jsonrpc-inhibit-debug-on-error t))
|
|
(jsonrpc-request conn '+ ["a" 2])
|
|
(ert-fail "A `jsonrpc-error' should have been signaled!"))
|
|
(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."
|
|
(skip-when (eq system-type 'windows-nt))
|
|
(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."
|
|
(skip-when (eq system-type 'windows-nt))
|
|
(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."
|
|
(skip-when (eq system-type 'windows-nt))
|
|
(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]])))))
|
|
|
|
(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 no one clears the flag."
|
|
(skip-when (eq system-type 'windows-nt))
|
|
(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."
|
|
(skip-when (eq system-type 'windows-nt))
|
|
;; 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."
|
|
(skip-when (eq system-type 'windows-nt))
|
|
(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)
|
|
;; Wait another 0.5 secs just in case the success handlers of
|
|
;; one of these last two requests didn't quite have a chance to
|
|
;; run (Emacs 25.2 apparently needs this).
|
|
(accept-process-output nil 0.5)
|
|
(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
|