diff --git a/base.lisp b/base.lisp index 0fdd2ff..251443f 100644 --- a/base.lisp +++ b/base.lisp @@ -18,6 +18,7 @@ #:event-base-dns-base #:event-base-dns-ref-count #:event-base-catch-app-errors + #:event-base-caught-errors #:event-base-default-event-handler #:event-base-lock #:event-base-num-connections-in @@ -72,18 +73,19 @@ ;; error handling (catch-app-errors :accessor event-base-catch-app-errors :initarg :catch-app-errors :initform nil :documentation "If true, attemps to trap all errors produced in the event loop and process them internally") + (caught-errors :accessor event-base-caught-errors :initarg :caught-errors :initform nil + :documentation "If set to a function, will be called with top-level caught errors.") (default-event-handler :accessor event-base-default-event-handler :initarg :default-event-handler :initform (lambda (err) - ;; throw the error so we can wrap it in a handler-case - (handler-case (error err) - ;; got a connection error, throw it (must - ;; do this explicitely since event-error - ;; extends event-info) - (event-error () (error err)) - - ;; this is just info, let it slide - (event-info () nil))) + (block exit + (handler-bind + (((and event-info + (not event-error)) + (lambda (e) + (declare (ignore e)) + (return-from exit)))) + (error err)))) :documentation "Used as the default event handler if one is not specified.") (lock :accessor event-base-lock :initarg :lock :initform (bt:make-lock) :documentation "Holds *the* lock for this event base.") diff --git a/event-loop.lisp b/event-loop.lisp index 0c4e73e..7f126e7 100644 --- a/event-loop.lisp +++ b/event-loop.lisp @@ -71,7 +71,7 @@ (uv:uv-run evloop (cffi:foreign-enum-value 'uv:uv-run-mode :+uv-run-default+)) (do-close-loop evloop (1+ loops))))) -(defun start-event-loop (start-fn &key default-event-cb (catch-app-errors nil catch-app-errors-supplied-p)) +(defun start-event-loop (start-fn &key default-event-cb (catch-app-errors nil catch-app-errors-supplied-p) caught-errors) "Simple wrapper function that starts an event loop which runs the given callback, most likely to init your server/client." (when *event-base* @@ -88,6 +88,8 @@ :id *event-base-next-id*) (when catch-app-errors-supplied-p (list :catch-app-errors catch-app-errors)) + (when caught-errors + (list :caught-errors caught-errors)) (when (functionp default-event-cb) (list :default-event-handler default-event-cb))))) (*buffer-writes* *buffer-writes*) @@ -118,7 +120,7 @@ (remhash (event-base-id *event-base*) *event-base-registry*)) (setf *event-base* nil))))) -(defmacro with-event-loop ((&key default-event-cb (catch-app-errors nil catch-app-errors-supplied-p)) +(defmacro with-event-loop ((&key default-event-cb (catch-app-errors nil catch-app-errors-supplied-p) caught-errors) &body body) "Makes starting an event loop a tad less annoying. I really couldn't take typing out `(start-event-loop (lambda () ...) ...) every time. Example: @@ -131,7 +133,9 @@ `(as:start-event-loop (lambda () ,@body) :default-event-cb ,default-event-cb) (when catch-app-errors-supplied-p - `(:catch-app-errors ,catch-app-errors)))) + `(:catch-app-errors ,catch-app-errors)) + (when caught-errors + `(:caught-errors ,caught-errors)))) (defun exit-event-loop () "Exit the event loop if running." diff --git a/test/base.lisp b/test/base.lisp index 701e0f4..f2cc515 100644 --- a/test/base.lisp +++ b/test/base.lisp @@ -19,17 +19,17 @@ (test catch-app-errors "Test the global event handler works appropriately" - (is (subtypep - (let ((err nil)) - (as:start-event-loop - (lambda () - (error "Test")) - :catch-app-errors t - :default-event-cb - (lambda (ev) - (setf err ev))) - (type-of err)) - 'error))) + (let ((err nil)) + (handler-case + (as:with-event-loop (:catch-app-errors nil) + (error "lool")) + (error (e) (setf err e))) + (is (subtypep (type-of err) 'error))) + (let ((err nil)) + (as:with-event-loop (:catch-app-errors t + :caught-errors (lambda (e) (setf err e))) + (error "oh noo")) + (is (subtypep (type-of err) 'error)))) (test data-and-fn-pointers "Test for the correct number of data/function pointers for a set of operations" diff --git a/util.lisp b/util.lisp index 5f3ad77..3cd2f8b 100644 --- a/util.lisp +++ b/util.lisp @@ -184,26 +184,34 @@ `(let ((*evcb-err* '())) (flet ((,thunk-fn () (call-with-callback-restarts #'(lambda () ,@body)))) - (if (event-base-catch-app-errors *event-base*) - (let ((,evcb (cond ((not (symbolp ,event-cb)) - ,event-cb) - ((fboundp ,event-cb) - (symbol-function ,event-cb)) - ((null ,event-cb) - (event-base-default-event-handler *event-base*)) - (t - (error "invalid event-cb: ~s" ,event-cb))))) - (block ,blk - (handler-bind - ((error #'(lambda (,err) - ;; check whether the error was already sent to eventcb - (unless (or (member ,err *evcb-err*) - (passthrough-error-p ,err)) - ;; if that's a new error, handle it by invoking event-cb - (funcall ,evcb ,err) - (return-from ,blk))))) - (,thunk-fn)))) - (,thunk-fn))))))) + (let ((,evcb (cond ((not (symbolp ,event-cb)) + ,event-cb) + ((fboundp ,event-cb) + (symbol-function ,event-cb)) + ((null ,event-cb) + (event-base-default-event-handler *event-base*)) + (t + (error "invalid event-cb: ~s" ,event-cb))))) + (block ,blk + (handler-bind + ((error #'(lambda (,err) + ;; check whether the error was already sent to eventcb + (unless (or (member ,err *evcb-err*) + (passthrough-error-p ,err)) + ;; if that's a new error, handle it by invoking event-cb + (when (typep ,err 'event-info) + (funcall ,evcb ,err)) + (when (event-base-catch-app-errors *event-base*) + (let* ((caught-errors (event-base-caught-errors *event-base*)) + (caught-errors (cond ((and (symbolp caught-errors) + (fboundp caught-errors)) + (symbol-function caught-errors)) + ((functionp caught-errors) + caught-errors)))) + (when caught-errors + (funcall caught-errors ,err)) + (return-from ,blk))))))) + (,thunk-fn))))))))) (defun run-event-cb (event-cb &rest args) "When used in the dynamic context of catch-app-errors, wraps the