X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Factors.scm;h=9009d301470a1c9872fd32cfe306b5f1b1b1653d;hp=f9b9047ac4a83fc1d06e82bb798422c0f7750dae;hb=9414dea358e9067f1d333650df1a228dcc4bf378;hpb=148aae4afbbbfa1a0845746294acb1385deda9b6 diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm index f9b9047..9009d30 100644 --- a/8sync/systems/actors.scm +++ b/8sync/systems/actors.scm @@ -35,7 +35,6 @@ actor-id - actor-hive actor-message-handler ;;; Commenting out the
type for now; @@ -59,6 +58,9 @@ hive-id hive-create-actor hive-create-actor* + create-actor create-actor* + self-destruct + make-message message? message-to message-action message-from @@ -70,7 +72,7 @@ reply-message reply-message-wait ez-run-hive - hive-bootstrap-message + bootstrap-message serialize-message write-message serialize-message-pretty pprint-message @@ -80,8 +82,8 @@ (define %random-state (make-parameter (random-state-from-platform))) -;; Probably bigger than necessary -(define random-number-size (expt 10 50)) +;; Same size as a uuid4 I think... +(define random-number-size (expt 2 128)) (define (big-random-number) (random random-number-size (%random-state))) @@ -116,9 +118,11 @@ (define-record-type (make-message-intern id to from action - body in-reply-to wants-reply ; do we need hive-proxy? - ;; Are these still needed? - replied deferred-reply) + body in-reply-to wants-reply + replied + ;; @@: Not used yet. + ;; Will we ever find a real use case? + deferred-reply) message? (id message-id) (to message-to) @@ -171,6 +175,13 @@ If key not found and DFLT not provided, throw an error." 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 '())) @@ -191,17 +202,17 @@ If key not found and DFLT not provided, throw an error." (message (make-message (hive-gen-message-id hive) to-id (actor-id from-actor) action (kwarg-list-to-alist message-body-args)))) - (8sync (hive-process-message hive message)))) + (8sync-nowait (hive-process-message hive message)))) (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))) - (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 @@ -218,21 +229,21 @@ If key not found and DFLT not provided, throw an error." (actor-id from-actor) '*reply* (kwarg-list-to-alist message-body-args) #:in-reply-to (message-id original-message)))) - (8sync (hive-process-message hive new-message)))) + (8sync-nowait (hive-process-message hive new-message)))) (define (reply-message-wait from-actor original-message . message-body-args) "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)))) - (abort-to-prompt agenda-prompt from-actor new-message))) + (abort-to-prompt abort-to from-actor new-message))) @@ -378,6 +389,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 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 @@ -437,7 +449,15 @@ more compact following syntax: (define-method (hive-process-message (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 @@ -446,36 +466,56 @@ more compact following syntax: (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) - (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)) - (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 @@ -513,7 +553,6 @@ so this gets called from the nicer hive-create-actor interface. See that method for documentation." (let* ((actor-id (hive-gen-actor-id hive id-cookie)) (actor (apply make actor-class - ;; @@: If we switch to a hive-proxy, do it here #:hive hive #:id actor-id init))) @@ -521,37 +560,43 @@ that method for documentation." ;; return the actor id actor-id)) -(define* (hive-create-actor hive actor-class - #:key - (init '()) - id-cookie) +(define* (hive-create-actor hive actor-class #:rest init) + (%hive-create-actor hive actor-class + init #f)) + +(define* (hive-create-actor* hive actor-class id-cookie #:rest init) (%hive-create-actor hive actor-class init id-cookie)) -(define-syntax hive-create-actor* - (syntax-rules () - "Create an instance of actor-class attached to this hive. -Return the new actor's id. -Used internally, and used for bootstrapping a fresh hive. + +;;; Various API methods for actors to interact with the system +;;; ========================================================== + +;; TODO: move send-message and friends here...? + +(define* (create-actor from-actor actor-class #:rest init) + "Create an instance of actor-class. Return the new actor's id. + +This is the method actors should call directly (unless they want +to supply an id-cookie, in which case they should use +create-actor*)." + (8sync (%hive-create-actor (actor-hive from-actor) actor-class + init #f))) + -Note that actors should generally not call this method directly. -Instead, actors should call create-actor." - ((_ args ... (init-args ...)) - (hive-create-actor args ... - #:init (list init-args ...))))) +(define* (create-actor* from-actor actor-class id-cookie #:rest init) + "Create an instance of actor-class. Return the new actor's id. +Like create-actor, but permits supplying an id-cookie." + (8sync (%hive-create-actor (actor-hive from-actor) actor-class + init id-cookie))) -;; TODO: Give actors this instead of the actual hive reference -(define-class () - (send-message #:getter proxy-send-message - #:init-keyword #:send-message) - (create-actor #:getter proxy-create-actor - #:init-keyword #:create-actor)) -;; Live the hive proxy, but has access to the hive itself... -(define-class () - (hive #:init-keyword #:hive)) +(define (self-destruct actor) + "Remove an actor from the hive." + (hash-remove! (hive-actor-registry (actor-hive actor)) + (actor-id actor))) @@ -575,7 +620,7 @@ an integer." (spawn-and-queue-repl-server! agenda))) (start-agenda agenda))) -(define (hive-bootstrap-message hive to-id action . message-body-args) +(define (bootstrap-message hive to-id action . message-body-args) (wrap (apply send-message hive to-id action message-body-args)))