Add option to log backtraces on handler error

Closes #87
rigetti · Nov 8, 2019 · 3d8fb79 · 3d8fb79
1 parent 011d595
commit 3d8fb79
Show file tree

Hide file tree

Showing 3 changed files with 53 additions and 7 deletions.
diff --git a/rpcq.asd b/rpcq.asd
@@ -30,6 +30,7 @@
                #:uuid                   ; UUID generation
                #:cl-syslog              ; send logs to syslogd
                #:flexi-streams          ; UTF8 encode/decode
+               #:trivial-backtrace      ; logging backtraces
                )
   :in-order-to ((asdf:test-op (asdf:test-op #:rpcq-tests)))
   :pathname "src/"

diff --git a/src-tests/test-rpc.lisp b/src-tests/test-rpc.lisp
@@ -159,3 +159,39 @@
               :do (sleep 1) (bt:destroy-thread server-thread))
         #-ccl
         (bt:destroy-thread server-thread)))))
+
+(defun oof-find-me-on-the-stack ()
+  (error "oof!"))
+
+(defun test-error-method ()
+  (oof-find-me-on-the-stack))
+
+(deftest test-log-backtrace ()
+  (with-unique-rpc-address (addr)
+    (let* ((log-stream (make-string-output-stream))
+           (server-function
+             (lambda ()
+               (let ((dt (rpcq:make-dispatch-table)))
+                 (rpcq:dispatch-table-add-handler dt 'test-error-method)
+                 (rpcq:start-server :dispatch-table dt
+                                    :listen-addresses (list addr)
+                                    :debug t
+                                    :logger (make-instance 'cl-syslog:rfc5424-logger
+                                                           :app-name "rpcq-tests"
+                                                           :facility ':local0
+                                                           :maximum-priority ':err
+                                                           :log-writer
+                                                           (cl-syslog:stream-log-writer log-stream))))))
+           (server-thread (bt:make-thread server-function)))
+      (sleep 1)
+      (unwind-protect
+           (rpcq:with-rpc-client (client addr)
+             (signals rpcq::rpc-error
+               (rpcq:rpc-call client "test-error-method"))
+             (is (search "OOF-FIND-ME-ON-THE-STACK" (get-output-stream-string log-stream))))
+        ;; 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/server.lisp b/src/server.lisp
@@ -149,6 +149,7 @@ By default, a symbol passed in for F will be automatically converted into the na
 
 (defun %rpc-server-thread-worker (&key
                                     dispatch-table
+                                    debug
                                     logger
                                     timeout
                                     pool-address)
@@ -202,12 +203,17 @@ DISPATCH-TABLE and LOGGING-STREAM are both required arguments.  TIMEOUT is of ty
                              (unless f
                                (error 'unknown-rpc-method
                                       :method-name (|RPCRequest-method| request)))
-                             (setf result
-                                   (if timeout
-                                       (bt:with-timeout (timeout)
-                                         (apply f (concatenate 'list args-as-list kwargs-as-plist)))
-                                       (apply f (concatenate 'list args-as-list kwargs-as-plist))))
-
+                             (flet ((apply-handler ()
+                                      (handler-bind
+                                          ((error (lambda (c)
+                                                    (when debug
+                                                      (cl-syslog:format-log logger ':err (trivial-backtrace:print-backtrace c :output nil))))))
+                                        (apply f (concatenate 'list args-as-list kwargs-as-plist)))))
+                               (setf result
+                                     (if timeout
+                                         (bt:with-timeout (timeout)
+                                           (apply-handler))
+                                         (apply-handler))))
                              (setf reply (make-instance '|RPCReply|
                                                         :|id| (|RPCRequest-id| request)
                                                         :|result| result
@@ -261,7 +267,8 @@ DISPATCH-TABLE and LOGGING-STREAM are both required arguments.  TIMEOUT is of ty
                        (thread-count 5)
                        (logger (make-instance 'cl-syslog:rfc5424-logger
                                               :log-writer (cl-syslog:null-log-writer)))
-                       timeout)
+                       timeout
+                       debug)
   "Main loop of an RPCQ server.
 
 Argument descriptions:
@@ -275,6 +282,7 @@ Argument descriptions:
   (check-type thread-count (integer 1))
   (check-type timeout (or null (real 0)))
   (check-type listen-addresses list)
+  (check-type debug boolean)
   (let ((pool-address (format nil "inproc://~a" (uuid:make-v4-uuid))))
     (cl-syslog:format-log logger ':info
                           "Spawning server at ~a .~%" listen-addresses)
@@ -288,6 +296,7 @@ Argument descriptions:
                (dotimes (j thread-count)
                  (push (bt:make-thread (lambda () (%rpc-server-thread-worker
                                                    :dispatch-table dispatch-table
+                                                   :debug debug
                                                    :logger logger
                                                    :timeout timeout
                                                    :pool-address pool-address))