actors: Catch all errors in the actor model.

[8sync.git] / 8sync / systems / actors.scm

diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm
index a5033135653422a8c8feb7db452a766fe9288d4c..0659eb52c95f45b5323dcf9e44e887a3a02ebc0a 100644 (file)
--- a/8sync/systems/actors.scm
+++ b/8sync/systems/actors.scm
@@ -48,7 +48,7 @@
             actor-id-string
 
             mlambda define-mhandler
-            make-action-dispatch
+            simple-dispatcher build-actions make-action-dispatch
             define-simple-actor
 
             <hive>
@@ -316,8 +316,14 @@ If key not found and DFLT not provided, throw an error."
 ;;; Actor utilities
 ;;; ===============
 
+
+(define-syntax-rule (with-message-args (message message-arg ...)
+                                       body body* ...)
+  (let ((message-arg (message-ref message (quote message-arg))) ...)
+    body body* ...))
+
 (define-syntax mlambda
-  (syntax-rules ()
+  (lambda (x)
     "A lambda for building message handlers.
 
 Use it like:
@@ -328,14 +334,19 @@ Which is like doing manually:
   (lambda (actor message)
     (let ((foo (message-ref message foo)))
       ...))"
-    ((_ (actor message message-arg ...)
-        body body* ...)
-     (lambda (actor message)
-       (let ((message-arg (message-ref message (quote message-arg))) ...)
-         body body* ...)))))
-
-;; @@: Sadly, docstrings won't work with this...
-;;   I think we need to bust out syntax-case to make that happen...
+    (syntax-case x ()
+      ((_ (actor message message-arg ...)
+          docstring
+          body ...)
+       (string? (syntax->datum #'docstring))
+       #'(lambda (actor message)
+           docstring
+           (with-message-args (message message-arg ...) body ...)))
+      ((_ (actor message message-arg ...)
+          body body* ...)
+       #'(lambda (actor message)
+           (with-message-args (message message-arg ...) body body* ...))))))
+
 (define-syntax-rule (define-mhandler (name actor message message-arg ...)
                       body ...)
   (define name
@@ -347,6 +358,8 @@ Which is like doing manually:
     (let* ((action (message-action message))
            (method (assoc-ref action-map action)))
       (if (not method)
+          ;; @@: There's every possibility this should be handled in
+          ;;  hive-process-message instead.
           (throw 'action-not-found
                  "No appropriate action handler found for actor"
                  #:action action
@@ -364,6 +377,15 @@ Which is like doing manually:
     ((_ (action-name handler))
      (cons (quote action-name) handler))))
 
+(define-syntax-rule (build-actions action-item ...)
+  "Build a mapping of actions.  Same syntax as make-action-dispatch
+but this doesn't build the dispatcher for you (you probably want to
+pass it to simple-dispatcher).
+
+The advantage here is that since this simply builds an alist, you can
+compose it with other action maps."
+  (list (%expand-action-item action-item) ...))
+
 (define-syntax make-action-dispatch
   (syntax-rules ()
     "Expand a list of action names and actions into an alist
@@ -385,8 +407,7 @@ more compact following syntax:
    ((party actor message)
      (display \"Life of the party!\")))"
     ((make-action-dispatch action-item ...)
-     (simple-dispatcher
-      (list (%expand-action-item action-item) ...)))))
+     (simple-dispatcher (build-actions action-item ...)))))
 
 (define-syntax-rule (define-simple-actor class actions ...)
   (define-class class (<actor>)
@@ -517,13 +538,23 @@ more compact following syntax:
 
   (define (call-catching-coroutine thunk)
     (define (call-catching-errors)
-      (with-throw-handler
-          #t thunk
-          (lambda (key . args)
-            (if (message-needs-reply message)
-                ;; If the message is waiting on a reply, let them know
-                ;; something went wrong.
-                (hive-reply-with-error hive message key args)))))
+      ;; TODO: maybe parameterize and use maybe-catch-all from agenda.scm
+      ;; @@: Why not just use with-throw-handler and let the catch
+      ;;   happen at the agenda?  That's what we used to do, but
+      ;;   it ended up with a SIGABRT.  See:
+      ;;     http://lists.gnu.org/archive/html/bug-guile/2016-05/msg00003.html
+      (catch #t
+        thunk
+        ;; In the actor model, we don't totally crash on errors.
+        (lambda _ #f)
+        ;; If an error happens, we raise it
+        (lambda (key . args)
+          (if (message-needs-reply message)
+              ;; If the message is waiting on a reply, let them know
+              ;; something went wrong.
+              (hive-reply-with-error hive message key args))
+          ;; print error message
+          (apply print-error-and-continue key args))))
     (call-with-prompt (hive-prompt hive)
       call-catching-errors
       (lambda (kont actor message)