diff --git a/src-tests/suite.lisp b/src-tests/suite.lisp index f8e6ef1..2eb312f 100644 --- a/src-tests/suite.lisp +++ b/src-tests/suite.lisp @@ -78,4 +78,22 @@ (cloned (rpcq::deserialize (rpcq::serialize original)))) (is (typep cloned 'rpcq::|RPCRequest|)) (is (string= (rpcq::|RPCRequest-id| original) (rpcq::|RPCRequest-id| cloned))) - (is (string= (rpcq::|RPCRequest-method| original) (rpcq::|RPCRequest-method| cloned))))) + (is (string= (rpcq::|RPCRequest-method| original) (rpcq::|RPCRequest-method| cloned)))) + + (let* ((warning (make-instance 'rpcq::|RPCWarning| + :|body| "The warning string." + :|kind| "The type of the warning raised.")) + (original (make-instance 'rpcq::|RPCError| + :|error| "The error message." + :|id| "The RPC request id." + :|warnings| `#(,warning))) + (cloned (rpcq::deserialize (rpcq::serialize original)))) + (is (typep cloned 'rpcq::|RPCError|)) + (let ((cloned-warnings (rpcq::|RPCError-warnings| cloned))) + (is (typep cloned-warnings 'vector)) + (is (= 1 (length cloned-warnings))) + (let ((cloned-warning (elt cloned-warnings 0))) + (is (string= (rpcq::|RPCWarning-body| warning) + (rpcq::|RPCWarning-body| cloned-warning))) + (is (string= (rpcq::|RPCWarning-kind| warning) + (rpcq::|RPCWarning-kind| cloned-warning))))))) diff --git a/src-tests/test-rpc.lisp b/src-tests/test-rpc.lisp index f7fac2b..bdc45f9 100644 --- a/src-tests/test-rpc.lisp +++ b/src-tests/test-rpc.lisp @@ -7,87 +7,111 @@ (defparameter *expected-response* "test-response") -(defun test-method (&key (sleep 1 sleep-p)) - (when sleep-p +(defun test-method (&key (sleep 1 slee-p)) + (when slee-p (sleep sleep)) "test-response") +;; TODO FIXME XXX The below relies on some funky/hacky/unsightly code +;; to forcefully kill threads. See open issues +;; https://github.com/rigetti/rpcq/issues/61 +;; https://github.com/rigetti/rpcq/issues/75 (deftest test-client-server-dialogue () - (let* ((server-function - (lambda () - (let ((dt (rpcq:make-dispatch-table))) - (rpcq:dispatch-table-add-handler dt 'test-method) - (rpcq:start-server :dispatch-table dt - :listen-addresses '("inproc://RPCQ-test"))))) - (server-thread (bt:make-thread server-function))) - (sleep 1) - (unwind-protect - ;; hook up the client - (rpcq:with-rpc-client (client "inproc://RPCQ-test") - ;; send a communique - (let ((server-response (rpcq:rpc-call client "test-method"))) - (is (string= *expected-response* server-response)))) - ;; kill the server thread - (bt:destroy-thread server-thread)))) + (with-unique-rpc-address (addr) + (let* ((server-function + (lambda () + (let ((dt (rpcq:make-dispatch-table))) + (rpcq:dispatch-table-add-handler dt 'test-method) + (rpcq:start-server :dispatch-table dt + :listen-addresses (list addr))))) + (server-thread (bt:make-thread server-function))) + (sleep 1) + (unwind-protect + ;; hook up the client + (rpcq:with-rpc-client (client addr) + ;; send a communique + (let ((server-response (rpcq:rpc-call client "test-method"))) + (is (string= *expected-response* server-response)))) + ;; kill the server thread + #+ccl + (loop :while (bt:thread-alive-p server-thread) + :do (sleep 1) (bt:destroy-thread server-thread)) + #-ccl + (bt:destroy-thread server-thread))))) (deftest test-client-timeout () - (let* ((server-function - (lambda () - (let ((dt (rpcq:make-dispatch-table))) - (rpcq:dispatch-table-add-handler dt 'test-method) - (rpcq:start-server :dispatch-table dt - :listen-addresses '("inproc://RPCQ-test"))))) - (server-thread (bt:make-thread server-function))) - (sleep 1) - (unwind-protect - ;; hook up the client - (rpcq:with-rpc-client (client "inproc://RPCQ-test" :timeout 1) - ;; send a communique - (signals sb-ext:timeout - (rpcq:rpc-call client "test-method" :sleep 5))) - ;; kill the server thread - (bt:destroy-thread server-thread)))) + (with-unique-rpc-address (addr) + (let* ((server-function + (lambda () + (let ((dt (rpcq:make-dispatch-table))) + (rpcq:dispatch-table-add-handler dt 'test-method) + (rpcq:start-server :dispatch-table dt + :listen-addresses (list addr))))) + (server-thread (bt:make-thread server-function))) + (sleep 1) + (unwind-protect + ;; hook up the client + (rpcq:with-rpc-client (client addr :timeout 1) + ;; send a communique + (signals bt:timeout + (rpcq:rpc-call client "test-method" :sleep 5))) + ;; kill the server thread + #+ccl + (loop :while (bt:thread-alive-p server-thread) + :do (sleep 1) (bt:destroy-thread server-thread)) + #-ccl + (bt:destroy-thread server-thread))))) (deftest test-server-timeout () - (let* ((server-function - (lambda () - (let ((dt (rpcq:make-dispatch-table))) - (rpcq:dispatch-table-add-handler dt 'test-method) - (rpcq:start-server :timeout 1 - :dispatch-table dt - :listen-addresses '("inproc://RPCQ-test"))))) - (server-thread (bt:make-thread server-function))) - (sleep 1) - (unwind-protect - ;; hook up the client - (rpcq:with-rpc-client (client "inproc://RPCQ-test") - ;; send a communique - (signals rpcq::rpc-error - (rpcq:rpc-call client "test-method" :sleep 5))) - ;; kill the server thread - (bt:destroy-thread server-thread)))) + (with-unique-rpc-address (addr) + (let* ((server-function + (lambda () + (let ((dt (rpcq:make-dispatch-table))) + (rpcq:dispatch-table-add-handler dt 'test-method) + (rpcq:start-server :timeout 1 + :dispatch-table dt + :listen-addresses (list addr))))) + (server-thread (bt:make-thread server-function))) + (sleep 1) + (unwind-protect + ;; hook up the client + (rpcq:with-rpc-client (client addr) + ;; send a communique + (signals rpcq::rpc-error + (rpcq:rpc-call client "test-method" :sleep 5))) + ;; kill the server thread + #+ccl + (loop :while (bt:thread-alive-p server-thread) + :do (sleep 1) (bt:destroy-thread server-thread)) + #-ccl + (bt:destroy-thread server-thread))))) (defun served-method () (warn "The purpose of this test is to communicate a warning.") "Some other reply payload.") (deftest test-server-warnings () - (let* ((server-function - (lambda () - (let ((dt (rpcq:make-dispatch-table))) - (rpcq:dispatch-table-add-handler dt 'served-method) - (rpcq:start-server :timeout 5 - :dispatch-table dt - :listen-addresses '("inproc://RPCQ-test"))))) - (server-thread (bt:make-thread server-function))) - (sleep 1) - (unwind-protect - ;; hook up the client - (rpcq:with-rpc-client (client "inproc://RPCQ-test") - ;; send a communique - (signals simple-warning - (is (string= "Some other reply payload." - (rpcq:rpc-call client "served-method"))))) - ;; kill the server thread - (bt:destroy-thread server-thread)))) + (with-unique-rpc-address (addr) + (let* ((server-function + (lambda () + (let ((dt (rpcq:make-dispatch-table))) + (rpcq:dispatch-table-add-handler dt 'served-method) + (rpcq:start-server :timeout 5 + :dispatch-table dt + :listen-addresses (list addr))))) + (server-thread (bt:make-thread server-function))) + (sleep 1) + (unwind-protect + ;; hook up the client + (rpcq:with-rpc-client (client addr) + ;; send a communique + (signals simple-warning + (is (string= "Some other reply payload." + (rpcq:rpc-call client "served-method"))))) + ;; kill the server thread + #+ccl + (loop :while (bt:thread-alive-p server-thread) + :do (sleep 1) (bt:destroy-thread server-thread)) + #-ccl + (bt:destroy-thread server-thread))))) diff --git a/src/package.lisp b/src/package.lisp index 03109d8..04e4c03 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -27,6 +27,7 @@ #:dispatch-table-add-handler #:start-server #:with-rpc-client + #:with-unique-rpc-address #:rpc-call ;; RPC client/server errors and error accessors #:not-an-rpcrequest diff --git a/src/rpcq.lisp b/src/rpcq.lisp index d1b5e05..1989e0a 100644 --- a/src/rpcq.lisp +++ b/src/rpcq.lisp @@ -37,7 +37,8 @@ (t (cerror "Just use the \"messages\" namespace." "Couldn't determine a valid namespace.") - "messages")))) + "messages"))) + (declaim (special *mocked-namespace*))) ;; store all messages defined thus far in their namespace (defvar *messages* (make-hash-table :test 'equal)) @@ -212,10 +213,10 @@ We distinguish between the following options for any field type: ;; handle lists ((eq ':list (car field-type)) - ;; Need not check if REQUIRED as NIL is still of type list - ;; We use 'simple-vector rather than 'list as this maps better to - ;; the JSON distinction betweel null and [] - (values 'simple-vector (coerce default 'simple-vector))) + ;; Need not check if REQUIRED as NIL is still of type list. We + ;; use 'vector rather than 'list as this maps better to the JSON + ;; distinction between null and [] + (values 'vector (coerce default 'vector))) ;; handle mappings ((eq ':map (car field-type)) diff --git a/src/utilities.lisp b/src/utilities.lisp index d483434..d5c5a47 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -28,3 +28,8 @@ (fboundp symbol) (not (macro-function symbol)) (not (special-operator-p symbol)))) + +(defmacro with-unique-rpc-address ((addr) &body body) + "Bind ADDR in the context of BODY to a unique address acceptable to RPCQ:START-SERVER." + `(let ((,addr (format nil "inproc://~a" (uuid:make-v4-uuid)))) + ,@body))