actors: Properly autoreply to replies; make reply-message-wait work.

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

diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm
index 87d29ec1b036b4fabae320b840a9866e86e5010d..8f00d570d9f5880d901a6063334e59e047d3f4d0 100644 (file)
--- a/8sync/systems/actors.scm
+++ b/8sync/systems/actors.scm
@@ -171,6 +171,13 @@ If key not found and DFLT not provided, throw an error."
             dflt))))
 
 
             dflt))))
 
 

+(define (message-needs-reply message)
+  "See if this message needs a reply still"
+  (and (message-wants-reply message)
+       (not (or (message-replied message)
+                (message-deferred-reply message)))))
+
+

 (define (kwarg-list-to-alist args)
   (let loop ((remaining args)
              (result '()))
 (define (kwarg-list-to-alist args)
   (let loop ((remaining args)
              (result '()))


@@ -196,12 +203,12 @@ If key not found and DFLT not provided, throw an error."
 (define (send-message-wait from-actor to-id action . message-body-args)
   "Send a message from an actor to another, but wait until we get a response"
   (let* ((hive (actor-hive from-actor))
 (define (send-message-wait from-actor to-id action . message-body-args)
   "Send a message from an actor to another, but wait until we get a response"
   (let* ((hive (actor-hive from-actor))

-         (agenda-prompt (hive-prompt (actor-hive from-actor)))
+         (abort-to (hive-prompt (actor-hive from-actor)))

          (message (make-message (hive-gen-message-id hive) to-id
                                 (actor-id from-actor) action
                                 (kwarg-list-to-alist message-body-args)
                                 #:wants-reply #t)))
          (message (make-message (hive-gen-message-id hive) to-id
                                 (actor-id from-actor) action
                                 (kwarg-list-to-alist message-body-args)
                                 #:wants-reply #t)))

-    (abort-to-prompt agenda-prompt from-actor message)))
+    (abort-to-prompt abort-to from-actor message)))

 
 ;; TODO: Intelligently ~propagate(ish) errors on -wait functions.
 ;;   We might have `send-message-wait-brazen' to allow callers to
 
 ;; TODO: Intelligently ~propagate(ish) errors on -wait functions.
 ;;   We might have `send-message-wait-brazen' to allow callers to


@@ -225,14 +232,14 @@ If key not found and DFLT not provided, throw an error."
   "Reply to a messsage, but wait until we get a response"
   (set-message-replied! original-message #t)
   (let* ((hive (actor-hive from-actor))
   "Reply to a messsage, but wait until we get a response"
   (set-message-replied! original-message #t)
   (let* ((hive (actor-hive from-actor))

-         (agenda-prompt (hive-prompt (actor-hive from-actor)))
+         (abort-to (hive-prompt (actor-hive from-actor)))

          (new-message (make-message (hive-gen-message-id hive)
                                     (message-from original-message)
                                     (actor-id from-actor) '*reply*
                                     (kwarg-list-to-alist message-body-args)
                                     #:wants-reply #t
                                     #:in-reply-to (message-id original-message))))
          (new-message (make-message (hive-gen-message-id hive)
                                     (message-from original-message)
                                     (actor-id from-actor) '*reply*
                                     (kwarg-list-to-alist message-body-args)
                                     #:wants-reply #t
                                     #:in-reply-to (message-id original-message))))

-    (abort-to-prompt agenda-prompt from-actor new-message)))
+    (abort-to-prompt abort-to from-actor new-message)))

 
 
 \f
 
 
 \f


@@ -349,7 +356,7 @@ more compact following syntax:
      (simple-dispatcher
       (list (%expand-action-item action-item) ...)))))
 
      (simple-dispatcher
       (list (%expand-action-item action-item) ...)))))
 

-(define-syntax-rule (define-simple-actor class (actions ...))
+(define-syntax-rule (define-simple-actor class actions ...)

   (define-class class (<actor>)
     (message-handler
      #:init-value (make-action-dispatch actions ...)
   (define-class class (<actor>)
     (message-handler
      #:init-value (make-action-dispatch actions ...)


@@ -378,6 +385,7 @@ more compact following syntax:
   ;; This is a map from cons cell of message-id
   ;;   to a cons cell of (actor-id . coroutine)
   ;; @@: Should we have a <waiting-coroutine> record type?
   ;; This is a map from cons cell of message-id
   ;;   to a cons cell of (actor-id . coroutine)
   ;; @@: Should we have a <waiting-coroutine> record type?

+  ;; @@: Should there be any way to clear out "old" coroutines?

   (waiting-coroutines #:init-thunk make-hash-table
                       #:getter hive-waiting-coroutines)
   ;; Message prompt
   (waiting-coroutines #:init-thunk make-hash-table
                       #:getter hive-waiting-coroutines)
   ;; Message prompt


@@ -437,7 +445,15 @@ more compact following syntax:
 
 (define-method (hive-process-message (hive <hive>) message)
   "Handle one message, or forward it via an ambassador"
 
 (define-method (hive-process-message (hive <hive>) message)
   "Handle one message, or forward it via an ambassador"

-  (define (process-local-message)
+  (define (maybe-autoreply actor)
+    ;; Possibly autoreply
+    (if (message-needs-reply message)
+        ;; @@: Should we give *autoreply* as the action instead of *reply*?
+        (reply-message actor message
+                       #:*auto-reply* #t)))
+
+  (define (resolve-actor-to)
+    "Get the actor the message was aimed at"

     (let ((actor (hive-resolve-local-actor hive (message-to message))))
       (if (not actor)
           (throw 'actor-not-found
     (let ((actor (hive-resolve-local-actor hive (message-to message))))
       (if (not actor)
           (throw 'actor-not-found


@@ -446,29 +462,56 @@ more compact following syntax:
                          (address->string (message-from message))
                          (address->string (message-to message)))
                  message))
                          (address->string (message-from message))
                          (address->string (message-to message)))
                  message))

-      (call-with-prompt (hive-prompt hive)
-        (lambda ()
-          (define message-handler (actor-message-handler actor))
-          ;; @@: Should a more general error handling happen here?
-          (message-handler actor message))
-
-        (lambda (kont actor message)
-          (let ((hive (actor-hive actor)))
-            ;; Register the coroutine
-            (hash-set! (hive-waiting-coroutines hive)
-                       (message-id message)
-                       (cons (actor-id actor) kont))
-            ;; Send off the message
-            (8sync (hive-process-message hive message)))))))
+      actor))
+
+  (define (call-catching-coroutine thunk)
+    (call-with-prompt (hive-prompt hive)
+      thunk
+      (lambda (kont actor message)
+        (let ((hive (actor-hive actor)))
+          ;; Register the coroutine
+          (hash-set! (hive-waiting-coroutines hive)
+                     (message-id message)
+                     (cons (actor-id actor) kont))
+          ;; Send off the message
+          (8sync (hive-process-message hive message))))))
+
+  (define (process-local-message)
+    (let ((actor (resolve-actor-to)))
+      (call-catching-coroutine
+       (lambda ()
+         (define message-handler (actor-message-handler actor))
+         ;; @@: Should a more general error handling happen here?
+         (let ((result
+                (message-handler actor message)))
+           (maybe-autoreply actor)
+           ;; Returning result allows actors to possibly make a run-request
+           ;; at the end of handling a message.
+           ;; ... We do want that, right?
+           result)))))

 
   (define (resume-waiting-coroutine)
 
   (define (resume-waiting-coroutine)

-    (match (hash-remove! (hive-waiting-coroutines hive)
-                         (message-in-reply-to message))
-      ((_ . kont)
-       (kont message))
-      (#f (throw 'no-waiting-coroutine
-                 "message in-reply-to tries to resume nonexistent coroutine"
-                 message))))
+    (call-catching-coroutine
+     (lambda ()
+       (match (hash-remove! (hive-waiting-coroutines hive)
+                            (message-in-reply-to message))
+         ((_ . (resume-actor-id . kont))
+          (if (not (equal? (message-to message)
+                           resume-actor-id))
+              (throw 'resuming-to-wrong-actor
+                     "Attempted to resume a coroutine to the wrong actor!"
+                     #:expected-actor-id (message-to message)
+                     #:got-actor-id resume-actor-id
+                     #:message message))
+          (let (;; @@: How should we resolve resuming coroutines to actors who are
+                ;;   now gone?
+                (actor (resolve-actor-to))
+                (result (kont message)))
+            (maybe-autoreply actor)
+            result))
+         (#f (throw 'no-waiting-coroutine
+                    "message in-reply-to tries to resume nonexistent coroutine"
+                    message))))))

 
   (define (process-remote-message)
     ;; Find the ambassador
 
   (define (process-remote-message)
     ;; Find the ambassador