From: Christopher Allan Webber Date: Tue, 20 Dec 2016 18:11:04 +0000 (-0600) Subject: actors: Move actors center-stage in 8sync. X-Git-Tag: v0.4.0~67 X-Git-Url: https://jxself.org/git/?p=8sync.git;a=commitdiff_plain;h=4deb5433574cfdf8f2b2bf22460c8b74ba426bed;hp=29745029f85cbc462bcfa0c75f92156ea2c6b494 actors: Move actors center-stage in 8sync. * 8sync/systems/actors.scm: Renamed to 8sync/actors.scm. * 8sync/systems/actors/debug.scm: Renamed to 8sync/debug.scm. * Makefile.am: Update for renamed files. * demos/actors/botherbotherbother.scm: * demos/actors/robotscanner.scm: * demos/actors/simplest-possible.scm: * tests/test-actors.scm: Update import of actors module to new location. --- diff --git a/8sync/actors.scm b/8sync/actors.scm new file mode 100644 index 0000000..fdcbc85 --- /dev/null +++ b/8sync/actors.scm @@ -0,0 +1,743 @@ +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2016 Christopher Allan Webber +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +(define-module (8sync actors) + #:use-module (oop goops) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 control) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (8sync agenda) + #:use-module (8sync repl) + #:export (;; utilities... ought to go in their own module + big-random-number + big-random-number-string + simple-message-id-generator + + + actor-id + actor-message-handler + + %current-actor + + ;;; Commenting out the
type for now; + ;;; it may be back when we have better serializers + ;;
+ make-address address? + address-actor-id address-hive-id + + address->string + actor-id-actor + actor-id-hive + actor-id-string + + build-actions + + define-simple-actor + + + make-hive + ;; There are more methods for the hive, but there's + ;; no reason for the outside world to look at them maybe? + hive-id + hive-create-actor hive-create-actor* + + create-actor create-actor* + self-destruct + + + make-message message? + message-to message-action message-from + message-id message-body message-in-reply-to + message-wants-reply + + message-auto-reply? + + <- <-wait <-reply <-reply-wait + + call-with-message msg-receive msg-val + + ez-run-hive + bootstrap-message + + serialize-message write-message + serialize-message-pretty pprint-message + read-message read-message-from-string)) + +;; For ids +(define %random-state + (make-parameter (random-state-from-platform))) + +;; Same size as a uuid4 I think... +(define random-number-size (expt 2 128)) + +(define (big-random-number) + (random random-number-size (%random-state))) + +;; Would be great to get this base64 encoded instead. +(define (big-random-number-string) + ;; @@: This is slow. Using format here is wasteful. + (format #f "~x" (big-random-number))) + +;; @@: This is slow. A mere ~275k / second on my (old) machine. +;; The main cost seems to be in number->string. +(define (simple-message-id-generator) + ;; Prepending this cookie makes message ids unique per hive + (let ((prefix (format #f "~x:" (big-random-number))) + (counter 0)) + (lambda () + (set! counter (1+ counter)) + (string-append prefix (number->string counter))))) + + + +;;; Messages +;;; ======== + + +;; @@: We may want to add a deferred-reply to the below, similar to +;; what we had in XUDD, for actors which do their own response +;; queueing.... ie, that might receive messages but need to shelve +;; them to be acted upon after something else is taken care of. + +(define-record-type + (make-message-intern id to from action + body in-reply-to wants-reply + replied) + message? + (id message-id) + (to message-to) + (from message-from) + (action message-action) + (body message-body) + (in-reply-to message-in-reply-to) + (wants-reply message-wants-reply) + (replied message-replied set-message-replied!)) + + +(define* (make-message id to from action body + #:key in-reply-to wants-reply + replied) + (make-message-intern id to from action body + in-reply-to wants-reply replied)) + +(define (message-auto-reply? message) + (eq? (message-action message) '*auto-reply*)) + +(define (message-needs-reply? message) + "See if this message needs a reply still" + (and (message-wants-reply message) + (not (message-replied message)))) + + +(define (kwarg-list-to-alist args) + (let loop ((remaining args) + (result '())) + (match remaining + (((? keyword? key) val rest ...) + (loop rest + (cons (cons (keyword->symbol key) val) + result))) + (() result) + (_ (throw 'invalid-kwarg-list + "Invalid keyword argument list" + args))))) + + +;;; See: https://web.archive.org/web/20081223021934/http://mumble.net/~jar/articles/oo-moon-weinreb.html +;;; (also worth seeing: http://mumble.net/~jar/articles/oo.html ) + +(define (<- from-actor to-id action . message-body-args) + "Send a message from an actor to another actor" + (let* ((hive (actor-hive from-actor)) + (message (make-message (hive-gen-message-id hive) to-id + (actor-id from-actor) action + message-body-args))) + (8sync (hive-process-message hive message)))) + +(define (<-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)) + (abort-to (hive-prompt (actor-hive from-actor))) + (message (make-message (hive-gen-message-id hive) to-id + (actor-id from-actor) action + message-body-args + #:wants-reply #t))) + (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 +;; not have an exception thrown and instead just have a message with +;; the appropriate '*error* message returned. + +(define (<-reply from-actor original-message . message-body-args) + "Reply to a message" + (set-message-replied! original-message #t) + (let* ((hive (actor-hive from-actor)) + (new-message (make-message (hive-gen-message-id hive) + (message-from original-message) + (actor-id from-actor) '*reply* + message-body-args + #:in-reply-to (message-id original-message)))) + (8sync (hive-process-message hive new-message)))) + +(define (<-auto-reply from-actor original-message) + "Auto-reply to a message. Internal use only!" + (set-message-replied! original-message #t) + (let* ((hive (actor-hive from-actor)) + (new-message (make-message (hive-gen-message-id hive) + (message-from original-message) + (actor-id from-actor) '*auto-reply* + '() + #:in-reply-to (message-id original-message)))) + (8sync (hive-process-message hive new-message)))) + +(define (<-reply-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)) + (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* + message-body-args + #:wants-reply #t + #:in-reply-to (message-id original-message)))) + (abort-to-prompt abort-to from-actor new-message))) + + + +;;; Main actor implementation +;;; ========================= + +(define (actor-inheritable-message-handler actor message) + (define action (message-action message)) + (define (find-message-handler return) + (for-each (lambda (this-class) + (define actions + (or (and (class-slot-definition this-class 'actions) + (class-slot-ref this-class 'actions)) + '())) + (for-each (match-lambda + ((action-name . method) + (when (eq? action-name action) + (return method)))) + actions)) + (class-precedence-list (class-of actor))) + (throw 'action-not-found + "No appropriate action handler found for actor" + #:action action + #:actor actor + #:message message)) + (define method + (call/ec find-message-handler)) + (apply method actor message (message-body message))) + +(define-class () + ;; An address object + (id #:init-keyword #:id + #:getter actor-id) + ;; The hive we're connected to. + ;; We need this to be able to send messages. + (hive #:init-keyword #:hive + #:accessor actor-hive) + ;; How we receive and process new messages + (message-handler #:init-value actor-inheritable-message-handler + ;; @@: There's no reason not to use #:class instead of + ;; #:each-subclass anywhere in this file, except for + ;; Guile bug #25211 (#:class is broken in Guile 2.2) + #:allocation #:each-subclass) + + ;; This is the default, "simple" way to inherit and process messages. + (actions #:init-value '() + #:allocation #:each-subclass)) + +(define-method (actor-message-handler (actor )) + (slot-ref actor 'message-handler)) + +;;; So these are the nicer representations of addresses. +;;; However, they don't serialize so easily with scheme read/write, so we're +;;; using the simpler cons cell version below for now. + +;; (define-record-type
+;; (make-address actor-id hive-id) ; @@: Do we want the trailing -id? +;; address? +;; (actor-id address-actor-id) +;; (hive-id address-hive-id)) +;; +;; (set-record-type-printer! +;;
+;; (lambda (record port) +;; (format port "" +;; (address-actor-id record) (address-hive-id record)))) +;; + +(define (make-address actor-id hive-id) + (cons actor-id hive-id)) + +(define (address-actor-id address) + (car address)) + +(define (address-hive-id address) + (cdr address)) + +(define (address->string address) + (string-append (address-actor-id address) "@" + (address-hive-id address))) + +(define-method (actor-id-actor (actor )) + "Get the actor id component of the actor-id" + (address-actor-id (actor-id actor))) + +(define-method (actor-id-hive (actor )) + "Get the hive id component of the actor-id" + (address-hive-id (actor-id actor))) + +(define-method (actor-id-string (actor )) + "Render the full actor id as a human-readable string" + (address->string (actor-id actor))) + +(define %current-actor + (make-parameter #f)) + + + +;;; Actor utilities +;;; =============== + +(define-syntax-rule (build-actions (symbol method) ...) + "Construct an alist of (symbol . method), where the method is wrapped +with wrap-apply to facilitate live hacking and allow the method definition +to come after class definition." + (list + (cons (quote symbol) + (wrap-apply method)) ...)) + +(define-syntax-rule (define-simple-actor class action ...) + (define-class class () + (actions #:init-value (build-actions action ...) + #:allocation #:each-subclass))) + + +;;; The Hive +;;; ======== +;;; Every actor has a hive. The hive is a kind of "meta-actor" +;;; which routes all the rest of the actors in a system. + +(define-generic hive-handle-failed-forward) + +(define-class () + (actor-registry #:init-thunk make-hash-table + #:getter hive-actor-registry) + (msg-id-generator #:init-thunk simple-message-id-generator + #:getter hive-msg-id-generator) + ;; Ambassadors are used (or will be) for inter-hive communication. + ;; These are special actors that know how to route messages to other hives. + (ambassadors #:init-thunk make-weak-key-hash-table + #:getter hive-ambassadors) + ;; Waiting coroutines + ;; 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 + ;; When actors send messages to each other they abort to this prompt + ;; to send the message, then carry on their way + (prompt #:init-thunk make-prompt-tag + #:getter hive-prompt) + (actions #:allocation #:each-subclass + #:init-value + (build-actions + ;; This is in the case of an ambassador failing to forward a + ;; message... it reports it back to the hive + (*failed-forward* hive-handle-failed-forward)))) + +(define-method (hive-handle-failed-forward (hive ) message) + "Handle an ambassador failing to forward a message" + 'TODO) + +(define* (make-hive #:key hive-id) + (let ((hive (make + #:id (make-address + "hive" (or hive-id + (big-random-number-string)))))) + ;; Set the hive's actor reference to itself + (set! (actor-hive hive) hive) + hive)) + +(define-method (hive-id (hive )) + (actor-id-hive hive)) + +(define-method (hive-gen-actor-id (hive ) cookie) + (make-address (if cookie + (string-append cookie "-" (big-random-number-string)) + (big-random-number-string)) + (hive-id hive))) + +(define-method (hive-gen-message-id (hive )) + "Generate a message id using HIVE's message id generator" + ((hive-msg-id-generator hive))) + +(define-method (hive-resolve-local-actor (hive ) actor-address) + (hash-ref (hive-actor-registry hive) actor-address)) + +(define-method (hive-resolve-ambassador (hive ) ambassador-address) + (hash-ref (hive-ambassadors hive) ambassador-address)) + +(define-method (make-forward-request (hive ) (ambassador ) message) + (make-message (hive-gen-message-id hive) (actor-id ambassador) + ;; If we make the hive not an actor, we could either switch this + ;; to #f or to the original actor...? + ;; Maybe some more thinking should be done on what should + ;; happen in case of failure to forward? Handling ambassador failures + ;; seems like the primary motivation for the hive remaining an actor. + (actor-id hive) + '*forward* + `((original . ,message)))) + +(define-method (hive-reply-with-error (hive ) original-message + error-key error-args) + ;; We only supply the error-args if the original sender is on the same hive + (define (orig-actor-on-same-hive?) + (equal? (hive-id hive) + (address-hive-id (message-from original-message)))) + (set-message-replied! original-message #t) + (let* ((new-message-body + (if (orig-actor-on-same-hive?) + `(#:original-message ,original-message + #:error-key ,error-key + #:error-args ,error-args) + `(#:original-message ,original-message + #:error-key ,error-key))) + (new-message (make-message (hive-gen-message-id hive) + (message-from original-message) + (actor-id hive) '*error* + new-message-body + #:in-reply-to (message-id original-message)))) + ;; We only return a thunk, rather than run 8sync here, because if + ;; we ran 8sync in the middle of a catch we'd end up with an + ;; unresumable continuation. + (lambda () (hive-process-message hive new-message)))) + +(define-method (hive-process-message (hive ) message) + "Handle one message, or forward it via an ambassador" + (define (maybe-autoreply actor) + ;; Possibly autoreply + (if (message-needs-reply? message) + (<-auto-reply actor message))) + + (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 + (format #f "Message ~a from ~a directed to nonexistant actor ~a" + (message-id message) + (address->string (message-from message)) + (address->string (message-to message))) + message)) + actor)) + + (define (call-catching-coroutine thunk) + (define queued-error-handling-thunk #f) + (define (call-catching-errors) + ;; TODO: maybe parameterize (or attach to hive) 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. + ;; However, we have to do it outside of this catch + ;; routine, or we'll end up in an unrewindable continuation + ;; situation. + (set! queued-error-handling-thunk + (hive-reply-with-error hive message key args))) + ;; print error message + (apply print-error-and-continue key args))) + ;; @@: This is a kludge. See above for why. + (if queued-error-handling-thunk + (8sync (queued-error-handling-thunk)))) + (call-with-prompt (hive-prompt hive) + call-catching-errors + (lambda (kont actor message) + ;; 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? + (parameterize ((%current-actor actor)) + (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) + (cond + ((or (eq? (message-action message) '*reply*) + (eq? (message-action message) '*auto-reply*)) + (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)))))) + ;; Yikes, we must have gotten an error or something back + (else + ;; @@: Not what we want in the long run? + ;; What we'd *prefer* to do is to resume this message + ;; and throw an error inside the message handler + ;; (say, from send-mesage-wait), but that causes a SIGABRT (??!!) + (hash-remove! (hive-waiting-coroutines hive) + (message-in-reply-to message)) + (let ((explaination + (if (eq? (message-action message) '*reply*) + "Won't resume coroutine; got an *error* as a reply" + "Won't resume coroutine because action is not *reply*"))) + (throw 'hive-unresumable-coroutine + explaination + #:message message))))) + + (define (process-remote-message) + ;; Find the ambassador + (let* ((remote-hive-id (hive-id (message-to message))) + (ambassador (hive-resolve-ambassador remote-hive-id)) + (message-handler (actor-message-handler ambassador)) + (forward-request (make-forward-request hive ambassador message))) + (message-handler ambassador forward-request))) + + (let ((to (message-to message))) + ;; This seems to be an easy mistake to make, so check that addressing + ;; is correct here + (if (not to) + (throw 'missing-addressee + "`to' field is missing on message" + #:message message)) + (if (hive-actor-local? hive to) + (if (message-in-reply-to message) + (resume-waiting-coroutine) + (process-local-message)) + (process-remote-message)))) + +(define-method (hive-actor-local? (hive ) address) + (equal? (hive-id hive) (address-hive-id address))) + +(define-method (hive-register-actor! (hive ) (actor )) + (hash-set! (hive-actor-registry hive) (actor-id actor) actor)) + +(define-method (%hive-create-actor (hive ) actor-class + init id-cookie) + "Actual method called by hive-create-actor. + +Since this is a define-method it can't accept fancy define* arguments, +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 + #:hive hive + #:id actor-id + init))) + (hive-register-actor! hive actor) + ;; return the actor id + actor-id)) + +(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 (call-with-message message proc) + "Applies message body arguments into procedure, with message as first +argument. Similar to call-with-values in concept." + (apply proc message (message-body message))) + +;; (msg-receive (<- bar baz) +;; (baz) +;; basil) + +;; Emacs: (put 'msg-receive 'scheme-indent-function 2) + +;; @@: Or receive-msg or receieve-message or?? +(define-syntax-rule (msg-receive arglist message body ...) + "Call body with arglist (which can accept arguments like lambda*) +applied from the message-body of message." + (call-with-message message + (lambda* arglist + body ...))) + +(define (msg-val message) + "Retrieve the first value from the message-body of message. +Like single value return from a procedure call. Probably the most +common case when waiting on a reply from some action invocation." + (call-with-message message + (lambda (_ val) val))) + + +;;; 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*)." + (%hive-create-actor (actor-hive from-actor) actor-class + init #f)) + + +(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." + (%hive-create-actor (actor-hive from-actor) actor-class + init id-cookie)) + + +(define (self-destruct actor) + "Remove an actor from the hive." + (hash-remove! (hive-actor-registry (actor-hive actor)) + (actor-id actor))) + + + +;;; 8sync bootstrap utilities +;;; ========================= + +(define* (ez-run-hive hive initial-tasks #:key repl-server) + "Start up an agenda and run HIVE in it with INITIAL-TASKS. + +Should we start up a cooperative REPL for live hacking? REPL-SERVER +wants to know! You can pass it #t or #f, or if you want to specify a port, +an integer." + (let* ((queue (list->q initial-tasks)) + (agenda (make-agenda #:pre-unwind-handler print-error-and-continue + #:queue queue))) + (cond + ;; If repl-server is an integer, we'll use that as the port + ((integer? repl-server) + (spawn-and-queue-repl-server! agenda repl-server)) + (repl-server + (spawn-and-queue-repl-server! agenda))) + (start-agenda agenda))) + +(define (bootstrap-message hive to-id action . message-body-args) + (wrap + (apply <- hive to-id action message-body-args))) + + + +;;; Basic readers / writers +;;; ======================= + +(define (serialize-message message) + "Serialize a message for read/write" + (list + (message-id message) + (message-to message) + (message-from message) + (message-action message) + (message-body message) + (message-in-reply-to message) + (message-wants-reply message) + (message-replied message))) + +(define* (write-message message #:optional (port (current-output-port))) + "Write out a message to a port for easy reading later. + +Note that if a sub-value can't be easily written to something +Guile's `read' procedure knows how to read, this doesn't do anything +to improve that. You'll need a better serializer for that.." + (write (serialize-message message) port)) + +(define (serialize-message-pretty message) + "Serialize a message in a way that's easy for humans to read." + `(*message* + (id ,(message-id message)) + (to ,(message-to message)) + (from ,(message-from message)) + (action ,(message-action message)) + (body ,(message-body message)) + (in-reply-to ,(message-in-reply-to message)) + (wants-reply ,(message-wants-reply message)) + (replied ,(message-replied message)))) + +(define (pprint-message message) + "Pretty print a message." + (pretty-print (serialize-message-pretty message))) + +(define* (read-message #:optional (port (current-input-port))) + "Read a message serialized via serialize-message from PORT" + (match (read port) + ((id to from action body in-reply-to wants-reply replied) + (make-message-intern + id to from action body + in-reply-to wants-reply replied)) + (anything-else + (throw 'message-read-bad-structure + "Could not read message from structure" + anything-else)))) + +(define (read-message-from-string message-str) + "Read message from MESSAGE-STR" + (with-input-from-string message-str + (lambda () + (read-message (current-input-port))))) diff --git a/8sync/debug.scm b/8sync/debug.scm new file mode 100644 index 0000000..a05f131 --- /dev/null +++ b/8sync/debug.scm @@ -0,0 +1,58 @@ +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2016 Christopher Allan Webber +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +(define-module (8sync debug) + #:use-module (oop goops) + #:use-module (8sync actors) + #:export (hive-resolve-local-actor + actor-hive + + hive-create-actor-gimmie + hive-create-actor-gimmie*)) + + +;;; Expose not normally exposed methods +;;; =================================== + +;; "private" kind of a misnomer +(define-syntax-rule (expose private-var) + (define private-var + (@@ (8sync actors) private-var))) + +(expose hive-resolve-local-actor) +(expose actor-hive) + + + +;;; Some utilities +;;; ============= + +(define (hive-create-actor-gimmie hive actor-class . init) + "Create an actor on the hive, and give us that actor. +Uses hive-create-actor* arguments." + (let ((actor-id (apply hive-create-actor hive actor-class init))) + (hive-resolve-local-actor hive actor-id))) + +(define (hive-create-actor-gimmie* hive actor-class id-cookie . init) + "Create an actor on the hive, and give us that actor. +Uses hive-create-actor* arguments." + (let ((actor-id (apply hive-create-actor* + hive actor-class id-cookie init))) + (hive-resolve-local-actor hive actor-id))) + + diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm deleted file mode 100644 index eed3930..0000000 --- a/8sync/systems/actors.scm +++ /dev/null @@ -1,745 +0,0 @@ -;;; 8sync --- Asynchronous programming for Guile -;;; Copyright (C) 2016 Christopher Allan Webber -;;; -;;; This file is part of 8sync. -;;; -;;; 8sync is free software: you can redistribute it and/or modify it -;;; under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; 8sync is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with 8sync. If not, see . - -;; XUDD inspired actor system - -(define-module (8sync systems actors) - #:use-module (oop goops) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (ice-9 control) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) - #:use-module (8sync agenda) - #:use-module (8sync repl) - #:export (;; utilities... ought to go in their own module - big-random-number - big-random-number-string - simple-message-id-generator - - - actor-id - actor-message-handler - - %current-actor - - ;;; Commenting out the
type for now; - ;;; it may be back when we have better serializers - ;;
- make-address address? - address-actor-id address-hive-id - - address->string - actor-id-actor - actor-id-hive - actor-id-string - - build-actions - - define-simple-actor - - - make-hive - ;; There are more methods for the hive, but there's - ;; no reason for the outside world to look at them maybe? - hive-id - hive-create-actor hive-create-actor* - - create-actor create-actor* - self-destruct - - - make-message message? - message-to message-action message-from - message-id message-body message-in-reply-to - message-wants-reply - - message-auto-reply? - - <- <-wait <-reply <-reply-wait - - call-with-message msg-receive msg-val - - ez-run-hive - bootstrap-message - - serialize-message write-message - serialize-message-pretty pprint-message - read-message read-message-from-string)) - -;; For ids -(define %random-state - (make-parameter (random-state-from-platform))) - -;; Same size as a uuid4 I think... -(define random-number-size (expt 2 128)) - -(define (big-random-number) - (random random-number-size (%random-state))) - -;; Would be great to get this base64 encoded instead. -(define (big-random-number-string) - ;; @@: This is slow. Using format here is wasteful. - (format #f "~x" (big-random-number))) - -;; @@: This is slow. A mere ~275k / second on my (old) machine. -;; The main cost seems to be in number->string. -(define (simple-message-id-generator) - ;; Prepending this cookie makes message ids unique per hive - (let ((prefix (format #f "~x:" (big-random-number))) - (counter 0)) - (lambda () - (set! counter (1+ counter)) - (string-append prefix (number->string counter))))) - - - -;;; Messages -;;; ======== - - -;; @@: We may want to add a deferred-reply to the below, similar to -;; what we had in XUDD, for actors which do their own response -;; queueing.... ie, that might receive messages but need to shelve -;; them to be acted upon after something else is taken care of. - -(define-record-type - (make-message-intern id to from action - body in-reply-to wants-reply - replied) - message? - (id message-id) - (to message-to) - (from message-from) - (action message-action) - (body message-body) - (in-reply-to message-in-reply-to) - (wants-reply message-wants-reply) - (replied message-replied set-message-replied!)) - - -(define* (make-message id to from action body - #:key in-reply-to wants-reply - replied) - (make-message-intern id to from action body - in-reply-to wants-reply replied)) - -(define (message-auto-reply? message) - (eq? (message-action message) '*auto-reply*)) - -(define (message-needs-reply? message) - "See if this message needs a reply still" - (and (message-wants-reply message) - (not (message-replied message)))) - - -(define (kwarg-list-to-alist args) - (let loop ((remaining args) - (result '())) - (match remaining - (((? keyword? key) val rest ...) - (loop rest - (cons (cons (keyword->symbol key) val) - result))) - (() result) - (_ (throw 'invalid-kwarg-list - "Invalid keyword argument list" - args))))) - - -;;; See: https://web.archive.org/web/20081223021934/http://mumble.net/~jar/articles/oo-moon-weinreb.html -;;; (also worth seeing: http://mumble.net/~jar/articles/oo.html ) - -(define (<- from-actor to-id action . message-body-args) - "Send a message from an actor to another actor" - (let* ((hive (actor-hive from-actor)) - (message (make-message (hive-gen-message-id hive) to-id - (actor-id from-actor) action - message-body-args))) - (8sync (hive-process-message hive message)))) - -(define (<-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)) - (abort-to (hive-prompt (actor-hive from-actor))) - (message (make-message (hive-gen-message-id hive) to-id - (actor-id from-actor) action - message-body-args - #:wants-reply #t))) - (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 -;; not have an exception thrown and instead just have a message with -;; the appropriate '*error* message returned. - -(define (<-reply from-actor original-message . message-body-args) - "Reply to a message" - (set-message-replied! original-message #t) - (let* ((hive (actor-hive from-actor)) - (new-message (make-message (hive-gen-message-id hive) - (message-from original-message) - (actor-id from-actor) '*reply* - message-body-args - #:in-reply-to (message-id original-message)))) - (8sync (hive-process-message hive new-message)))) - -(define (<-auto-reply from-actor original-message) - "Auto-reply to a message. Internal use only!" - (set-message-replied! original-message #t) - (let* ((hive (actor-hive from-actor)) - (new-message (make-message (hive-gen-message-id hive) - (message-from original-message) - (actor-id from-actor) '*auto-reply* - '() - #:in-reply-to (message-id original-message)))) - (8sync (hive-process-message hive new-message)))) - -(define (<-reply-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)) - (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* - message-body-args - #:wants-reply #t - #:in-reply-to (message-id original-message)))) - (abort-to-prompt abort-to from-actor new-message))) - - - -;;; Main actor implementation -;;; ========================= - -(define (actor-inheritable-message-handler actor message) - (define action (message-action message)) - (define (find-message-handler return) - (for-each (lambda (this-class) - (define actions - (or (and (class-slot-definition this-class 'actions) - (class-slot-ref this-class 'actions)) - '())) - (for-each (match-lambda - ((action-name . method) - (when (eq? action-name action) - (return method)))) - actions)) - (class-precedence-list (class-of actor))) - (throw 'action-not-found - "No appropriate action handler found for actor" - #:action action - #:actor actor - #:message message)) - (define method - (call/ec find-message-handler)) - (apply method actor message (message-body message))) - -(define-class () - ;; An address object - (id #:init-keyword #:id - #:getter actor-id) - ;; The hive we're connected to. - ;; We need this to be able to send messages. - (hive #:init-keyword #:hive - #:accessor actor-hive) - ;; How we receive and process new messages - (message-handler #:init-value actor-inheritable-message-handler - ;; @@: There's no reason not to use #:class instead of - ;; #:each-subclass anywhere in this file, except for - ;; Guile bug #25211 (#:class is broken in Guile 2.2) - #:allocation #:each-subclass) - - ;; This is the default, "simple" way to inherit and process messages. - (actions #:init-value '() - #:allocation #:each-subclass)) - -(define-method (actor-message-handler (actor )) - (slot-ref actor 'message-handler)) - -;;; So these are the nicer representations of addresses. -;;; However, they don't serialize so easily with scheme read/write, so we're -;;; using the simpler cons cell version below for now. - -;; (define-record-type
-;; (make-address actor-id hive-id) ; @@: Do we want the trailing -id? -;; address? -;; (actor-id address-actor-id) -;; (hive-id address-hive-id)) -;; -;; (set-record-type-printer! -;;
-;; (lambda (record port) -;; (format port "" -;; (address-actor-id record) (address-hive-id record)))) -;; - -(define (make-address actor-id hive-id) - (cons actor-id hive-id)) - -(define (address-actor-id address) - (car address)) - -(define (address-hive-id address) - (cdr address)) - -(define (address->string address) - (string-append (address-actor-id address) "@" - (address-hive-id address))) - -(define-method (actor-id-actor (actor )) - "Get the actor id component of the actor-id" - (address-actor-id (actor-id actor))) - -(define-method (actor-id-hive (actor )) - "Get the hive id component of the actor-id" - (address-hive-id (actor-id actor))) - -(define-method (actor-id-string (actor )) - "Render the full actor id as a human-readable string" - (address->string (actor-id actor))) - -(define %current-actor - (make-parameter #f)) - - - -;;; Actor utilities -;;; =============== - -(define-syntax-rule (build-actions (symbol method) ...) - "Construct an alist of (symbol . method), where the method is wrapped -with wrap-apply to facilitate live hacking and allow the method definition -to come after class definition." - (list - (cons (quote symbol) - (wrap-apply method)) ...)) - -(define-syntax-rule (define-simple-actor class action ...) - (define-class class () - (actions #:init-value (build-actions action ...) - #:allocation #:each-subclass))) - - -;;; The Hive -;;; ======== -;;; Every actor has a hive. The hive is a kind of "meta-actor" -;;; which routes all the rest of the actors in a system. - -(define-generic hive-handle-failed-forward) - -(define-class () - (actor-registry #:init-thunk make-hash-table - #:getter hive-actor-registry) - (msg-id-generator #:init-thunk simple-message-id-generator - #:getter hive-msg-id-generator) - ;; Ambassadors are used (or will be) for inter-hive communication. - ;; These are special actors that know how to route messages to other hives. - (ambassadors #:init-thunk make-weak-key-hash-table - #:getter hive-ambassadors) - ;; Waiting coroutines - ;; 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 - ;; When actors send messages to each other they abort to this prompt - ;; to send the message, then carry on their way - (prompt #:init-thunk make-prompt-tag - #:getter hive-prompt) - (actions #:allocation #:each-subclass - #:init-value - (build-actions - ;; This is in the case of an ambassador failing to forward a - ;; message... it reports it back to the hive - (*failed-forward* hive-handle-failed-forward)))) - -(define-method (hive-handle-failed-forward (hive ) message) - "Handle an ambassador failing to forward a message" - 'TODO) - -(define* (make-hive #:key hive-id) - (let ((hive (make - #:id (make-address - "hive" (or hive-id - (big-random-number-string)))))) - ;; Set the hive's actor reference to itself - (set! (actor-hive hive) hive) - hive)) - -(define-method (hive-id (hive )) - (actor-id-hive hive)) - -(define-method (hive-gen-actor-id (hive ) cookie) - (make-address (if cookie - (string-append cookie "-" (big-random-number-string)) - (big-random-number-string)) - (hive-id hive))) - -(define-method (hive-gen-message-id (hive )) - "Generate a message id using HIVE's message id generator" - ((hive-msg-id-generator hive))) - -(define-method (hive-resolve-local-actor (hive ) actor-address) - (hash-ref (hive-actor-registry hive) actor-address)) - -(define-method (hive-resolve-ambassador (hive ) ambassador-address) - (hash-ref (hive-ambassadors hive) ambassador-address)) - -(define-method (make-forward-request (hive ) (ambassador ) message) - (make-message (hive-gen-message-id hive) (actor-id ambassador) - ;; If we make the hive not an actor, we could either switch this - ;; to #f or to the original actor...? - ;; Maybe some more thinking should be done on what should - ;; happen in case of failure to forward? Handling ambassador failures - ;; seems like the primary motivation for the hive remaining an actor. - (actor-id hive) - '*forward* - `((original . ,message)))) - -(define-method (hive-reply-with-error (hive ) original-message - error-key error-args) - ;; We only supply the error-args if the original sender is on the same hive - (define (orig-actor-on-same-hive?) - (equal? (hive-id hive) - (address-hive-id (message-from original-message)))) - (set-message-replied! original-message #t) - (let* ((new-message-body - (if (orig-actor-on-same-hive?) - `(#:original-message ,original-message - #:error-key ,error-key - #:error-args ,error-args) - `(#:original-message ,original-message - #:error-key ,error-key))) - (new-message (make-message (hive-gen-message-id hive) - (message-from original-message) - (actor-id hive) '*error* - new-message-body - #:in-reply-to (message-id original-message)))) - ;; We only return a thunk, rather than run 8sync here, because if - ;; we ran 8sync in the middle of a catch we'd end up with an - ;; unresumable continuation. - (lambda () (hive-process-message hive new-message)))) - -(define-method (hive-process-message (hive ) message) - "Handle one message, or forward it via an ambassador" - (define (maybe-autoreply actor) - ;; Possibly autoreply - (if (message-needs-reply? message) - (<-auto-reply actor message))) - - (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 - (format #f "Message ~a from ~a directed to nonexistant actor ~a" - (message-id message) - (address->string (message-from message)) - (address->string (message-to message))) - message)) - actor)) - - (define (call-catching-coroutine thunk) - (define queued-error-handling-thunk #f) - (define (call-catching-errors) - ;; TODO: maybe parameterize (or attach to hive) 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. - ;; However, we have to do it outside of this catch - ;; routine, or we'll end up in an unrewindable continuation - ;; situation. - (set! queued-error-handling-thunk - (hive-reply-with-error hive message key args))) - ;; print error message - (apply print-error-and-continue key args))) - ;; @@: This is a kludge. See above for why. - (if queued-error-handling-thunk - (8sync (queued-error-handling-thunk)))) - (call-with-prompt (hive-prompt hive) - call-catching-errors - (lambda (kont actor message) - ;; 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? - (parameterize ((%current-actor actor)) - (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) - (cond - ((or (eq? (message-action message) '*reply*) - (eq? (message-action message) '*auto-reply*)) - (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)))))) - ;; Yikes, we must have gotten an error or something back - (else - ;; @@: Not what we want in the long run? - ;; What we'd *prefer* to do is to resume this message - ;; and throw an error inside the message handler - ;; (say, from send-mesage-wait), but that causes a SIGABRT (??!!) - (hash-remove! (hive-waiting-coroutines hive) - (message-in-reply-to message)) - (let ((explaination - (if (eq? (message-action message) '*reply*) - "Won't resume coroutine; got an *error* as a reply" - "Won't resume coroutine because action is not *reply*"))) - (throw 'hive-unresumable-coroutine - explaination - #:message message))))) - - (define (process-remote-message) - ;; Find the ambassador - (let* ((remote-hive-id (hive-id (message-to message))) - (ambassador (hive-resolve-ambassador remote-hive-id)) - (message-handler (actor-message-handler ambassador)) - (forward-request (make-forward-request hive ambassador message))) - (message-handler ambassador forward-request))) - - (let ((to (message-to message))) - ;; This seems to be an easy mistake to make, so check that addressing - ;; is correct here - (if (not to) - (throw 'missing-addressee - "`to' field is missing on message" - #:message message)) - (if (hive-actor-local? hive to) - (if (message-in-reply-to message) - (resume-waiting-coroutine) - (process-local-message)) - (process-remote-message)))) - -(define-method (hive-actor-local? (hive ) address) - (equal? (hive-id hive) (address-hive-id address))) - -(define-method (hive-register-actor! (hive ) (actor )) - (hash-set! (hive-actor-registry hive) (actor-id actor) actor)) - -(define-method (%hive-create-actor (hive ) actor-class - init id-cookie) - "Actual method called by hive-create-actor. - -Since this is a define-method it can't accept fancy define* arguments, -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 - #:hive hive - #:id actor-id - init))) - (hive-register-actor! hive actor) - ;; return the actor id - actor-id)) - -(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 (call-with-message message proc) - "Applies message body arguments into procedure, with message as first -argument. Similar to call-with-values in concept." - (apply proc message (message-body message))) - -;; (msg-receive (<- bar baz) -;; (baz) -;; basil) - -;; Emacs: (put 'msg-receive 'scheme-indent-function 2) - -;; @@: Or receive-msg or receieve-message or?? -(define-syntax-rule (msg-receive arglist message body ...) - "Call body with arglist (which can accept arguments like lambda*) -applied from the message-body of message." - (call-with-message message - (lambda* arglist - body ...))) - -(define (msg-val message) - "Retrieve the first value from the message-body of message. -Like single value return from a procedure call. Probably the most -common case when waiting on a reply from some action invocation." - (call-with-message message - (lambda (_ val) val))) - - -;;; 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*)." - (%hive-create-actor (actor-hive from-actor) actor-class - init #f)) - - -(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." - (%hive-create-actor (actor-hive from-actor) actor-class - init id-cookie)) - - -(define (self-destruct actor) - "Remove an actor from the hive." - (hash-remove! (hive-actor-registry (actor-hive actor)) - (actor-id actor))) - - - -;;; 8sync bootstrap utilities -;;; ========================= - -(define* (ez-run-hive hive initial-tasks #:key repl-server) - "Start up an agenda and run HIVE in it with INITIAL-TASKS. - -Should we start up a cooperative REPL for live hacking? REPL-SERVER -wants to know! You can pass it #t or #f, or if you want to specify a port, -an integer." - (let* ((queue (list->q initial-tasks)) - (agenda (make-agenda #:pre-unwind-handler print-error-and-continue - #:queue queue))) - (cond - ;; If repl-server is an integer, we'll use that as the port - ((integer? repl-server) - (spawn-and-queue-repl-server! agenda repl-server)) - (repl-server - (spawn-and-queue-repl-server! agenda))) - (start-agenda agenda))) - -(define (bootstrap-message hive to-id action . message-body-args) - (wrap - (apply <- hive to-id action message-body-args))) - - - -;;; Basic readers / writers -;;; ======================= - -(define (serialize-message message) - "Serialize a message for read/write" - (list - (message-id message) - (message-to message) - (message-from message) - (message-action message) - (message-body message) - (message-in-reply-to message) - (message-wants-reply message) - (message-replied message))) - -(define* (write-message message #:optional (port (current-output-port))) - "Write out a message to a port for easy reading later. - -Note that if a sub-value can't be easily written to something -Guile's `read' procedure knows how to read, this doesn't do anything -to improve that. You'll need a better serializer for that.." - (write (serialize-message message) port)) - -(define (serialize-message-pretty message) - "Serialize a message in a way that's easy for humans to read." - `(*message* - (id ,(message-id message)) - (to ,(message-to message)) - (from ,(message-from message)) - (action ,(message-action message)) - (body ,(message-body message)) - (in-reply-to ,(message-in-reply-to message)) - (wants-reply ,(message-wants-reply message)) - (replied ,(message-replied message)))) - -(define (pprint-message message) - "Pretty print a message." - (pretty-print (serialize-message-pretty message))) - -(define* (read-message #:optional (port (current-input-port))) - "Read a message serialized via serialize-message from PORT" - (match (read port) - ((id to from action body in-reply-to wants-reply replied) - (make-message-intern - id to from action body - in-reply-to wants-reply replied)) - (anything-else - (throw 'message-read-bad-structure - "Could not read message from structure" - anything-else)))) - -(define (read-message-from-string message-str) - "Read message from MESSAGE-STR" - (with-input-from-string message-str - (lambda () - (read-message (current-input-port))))) diff --git a/8sync/systems/actors/debug.scm b/8sync/systems/actors/debug.scm deleted file mode 100644 index 465751c..0000000 --- a/8sync/systems/actors/debug.scm +++ /dev/null @@ -1,58 +0,0 @@ -;;; 8sync --- Asynchronous programming for Guile -;;; Copyright (C) 2016 Christopher Allan Webber -;;; -;;; This file is part of 8sync. -;;; -;;; 8sync is free software: you can redistribute it and/or modify it -;;; under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; 8sync is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with 8sync. If not, see . - -(define-module (8sync systems actors debug) - #:use-module (oop goops) - #:use-module (8sync systems actors) - #:export (hive-resolve-local-actor - actor-hive - - hive-create-actor-gimmie - hive-create-actor-gimmie*)) - - -;;; Expose not normally exposed methods -;;; =================================== - -;; "private" kind of a misnomer -(define-syntax-rule (expose private-var) - (define private-var - (@@ (8sync systems actors) private-var))) - -(expose hive-resolve-local-actor) -(expose actor-hive) - - - -;;; Some utilities -;;; ============= - -(define (hive-create-actor-gimmie hive actor-class . init) - "Create an actor on the hive, and give us that actor. -Uses hive-create-actor* arguments." - (let ((actor-id (apply hive-create-actor hive actor-class init))) - (hive-resolve-local-actor hive actor-id))) - -(define (hive-create-actor-gimmie* hive actor-class id-cookie . init) - "Create an actor on the hive, and give us that actor. -Uses hive-create-actor* arguments." - (let ((actor-id (apply hive-create-actor* - hive actor-class id-cookie init))) - (hive-resolve-local-actor hive actor-id))) - - diff --git a/Makefile.am b/Makefile.am index 654de77..83ab6b0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -48,8 +48,8 @@ SOURCES = \ 8sync/agenda.scm \ 8sync/repl.scm \ 8sync/systems/irc.scm \ - 8sync/systems/actors.scm \ - 8sync/systems/actors/debug.scm + 8sync/actors.scm \ + 8sync/debug.scm TESTS = \ tests/test-agenda.scm \ diff --git a/demos/actors/botherbotherbother.scm b/demos/actors/botherbotherbother.scm index 48270f2..356a6a9 100755 --- a/demos/actors/botherbotherbother.scm +++ b/demos/actors/botherbotherbother.scm @@ -23,7 +23,7 @@ ;; Puppet show simulator. (use-modules (8sync agenda) - (8sync systems actors) + (8sync actors) (oop goops) (ice-9 hash-table) (ice-9 format)) diff --git a/demos/actors/robotscanner.scm b/demos/actors/robotscanner.scm index 9ab5765..e8d2cc8 100644 --- a/demos/actors/robotscanner.scm +++ b/demos/actors/robotscanner.scm @@ -33,7 +33,7 @@ ;;; reporting info back to the user.) ;;; ===================================================================== -(use-modules (8sync systems actors) +(use-modules (8sync actors) (oop goops) (ice-9 match)) diff --git a/demos/actors/simplest-possible.scm b/demos/actors/simplest-possible.scm index 8496b92..13aea1c 100644 --- a/demos/actors/simplest-possible.scm +++ b/demos/actors/simplest-possible.scm @@ -16,7 +16,7 @@ ;;; You should have received a copy of the GNU Lesser General Public ;;; License along with 8sync. If not, see . -(use-modules (8sync systems actors) +(use-modules (8sync actors) (oop goops)) (define-simple-actor diff --git a/tests/test-actors.scm b/tests/test-actors.scm index 6e59198..73927cd 100644 --- a/tests/test-actors.scm +++ b/tests/test-actors.scm @@ -18,7 +18,7 @@ (define-module (tests test-actors) #:use-module (srfi srfi-64) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (oop goops) #:use-module (tests utils)) @@ -68,7 +68,7 @@ (test-equal (getter test-message) (getter reread-message))) (list message-id message-to message-from message-action message-body message-in-reply-to message-wants-reply - (@@ (8sync systems actors) message-replied)))) + (@@ (8sync actors) message-replied)))) ;;; Test reply / autoreply