1 ;;; 8sync --- Asynchronous programming for Guile
2 ;;; Copyright (C) 2016 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; This file is part of 8sync.
6 ;;; 8sync is free software: you can redistribute it and/or modify it
7 ;;; under the terms of the GNU Lesser General Public License as
8 ;;; published by the Free Software Foundation, either version 3 of the
9 ;;; License, or (at your option) any later version.
11 ;;; 8sync is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU Lesser General Public License for more details.
16 ;;; You should have received a copy of the GNU Lesser General Public
17 ;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
19 ;; XUDD inspired actor system
21 (define-module (8sync systems actors)
22 #:use-module (oop goops)
23 #:use-module (srfi srfi-9)
24 #:use-module (srfi srfi-9 gnu)
25 #:use-module (ice-9 format)
26 #:use-module (ice-9 match)
27 #:use-module (ice-9 pretty-print)
28 #:use-module (8sync agenda)
29 #:use-module (8sync repl)
30 #:export (;; utilities... ought to go in their own module
32 big-random-number-string
33 simple-message-id-generator
39 ;;; Commenting out the <address> type for now;
40 ;;; it may be back when we have better serializers
43 address-actor-id address-hive-id
50 mlambda define-mhandler
51 simple-dispatcher build-actions make-action-dispatch
56 ;; There are more methods for the hive, but there's
57 ;; no reason for the outside world to look at them maybe?
59 hive-create-actor hive-create-actor*
61 create-actor create-actor*
66 message-to message-action message-from
67 message-id message-body message-in-reply-to
71 send-message send-message-wait
72 reply-message reply-message-wait
74 <- <-wait <-reply <-reply-wait
79 serialize-message write-message
80 serialize-message-pretty pprint-message
81 read-message read-message-from-string))
85 (make-parameter (random-state-from-platform)))
87 ;; Same size as a uuid4 I think...
88 (define random-number-size (expt 2 128))
90 (define (big-random-number)
91 (random random-number-size (%random-state)))
93 ;; Would be great to get this base64 encoded instead.
94 (define (big-random-number-string)
95 ;; @@: This is slow. Using format here is wasteful.
96 (format #f "~x" (big-random-number)))
98 ;; @@: This is slow. A mere ~275k / second on my (old) machine.
99 ;; The main cost seems to be in number->string.
100 (define (simple-message-id-generator)
101 ;; Prepending this cookie makes message ids unique per hive
102 (let ((prefix (format #f "~x:" (big-random-number)))
105 (set! counter (1+ counter))
106 (string-append prefix (number->string counter)))))
114 (define-record-type <message>
115 (make-message-intern id to from action
116 body in-reply-to wants-reply
119 ;; Will we ever find a real use case?
125 (action message-action)
127 (in-reply-to message-in-reply-to)
128 (wants-reply message-wants-reply)
130 ;; See XUDD source for these. Not use yet, maybe eventually will be?
131 ;; XUDD uses them for autoreply.
132 ;; Requiring mutation on message objects is clearly not great,
133 ;; but it may be worth it...? Investigate!
134 (replied message-replied set-message-replied!)
135 (deferred-reply message-deferred-reply set-message-deferred-reply!))
138 (define* (make-message id to from action body
139 #:key in-reply-to wants-reply
140 replied deferred-reply)
141 (make-message-intern id to from action body
142 in-reply-to wants-reply replied
145 ;; Note: the body of messages is currently an alist, but it's created
146 ;; from a keyword based property list (see the following two functions).
147 ;; But, that's an extra conversion step, and maybe totally unnecessary:
148 ;; we already have message-ref, and this could just pull a keyword
149 ;; from a property list.
150 ;; The main ways this might be useful are error checking,
151 ;; serialization across the wire (but even that might require some
152 ;; change), and using existing tooling (though adding new tooling
153 ;; would be negligible in implementation effort.)
155 ;; This cons cell is immutable and unique (for eq? tests)
156 (define %nothing-provided (cons 'nothing 'provided))
158 (define* (message-ref message key #:optional (dflt %nothing-provided))
159 "Extract KEY from body of MESSAGE.
161 Optionally set default with [DFLT]
162 If key not found and DFLT not provided, throw an error."
163 (let ((result (assoc key (message-body message))))
164 (if result (cdr result)
165 (if (eq? dflt %nothing-provided)
166 (throw 'message-missing-key
167 "Message body does not contain key and no default provided"
173 (define (message-needs-reply message)
174 "See if this message needs a reply still"
175 (and (message-wants-reply message)
176 (not (or (message-replied message)
177 (message-deferred-reply message)))))
180 (define (kwarg-list-to-alist args)
181 (let loop ((remaining args)
184 (((? keyword? key) val rest ...)
186 (cons (cons (keyword->symbol key) val)
189 (_ (throw 'invalid-kwarg-list
190 "Invalid keyword argument list"
194 (define (send-message from-actor to-id action . message-body-args)
195 "Send a message from an actor to another actor"
196 (let* ((hive (actor-hive from-actor))
197 (message (make-message (hive-gen-message-id hive) to-id
198 (actor-id from-actor) action
199 (kwarg-list-to-alist message-body-args))))
200 (8sync (hive-process-message hive message))))
202 (define (send-message-wait from-actor to-id action . message-body-args)
203 "Send a message from an actor to another, but wait until we get a response"
204 (let* ((hive (actor-hive from-actor))
205 (abort-to (hive-prompt (actor-hive from-actor)))
206 (message (make-message (hive-gen-message-id hive) to-id
207 (actor-id from-actor) action
208 (kwarg-list-to-alist message-body-args)
210 (abort-to-prompt abort-to from-actor message)))
212 ;; TODO: Intelligently ~propagate(ish) errors on -wait functions.
213 ;; We might have `send-message-wait-brazen' to allow callers to
214 ;; not have an exception thrown and instead just have a message with
215 ;; the appropriate '*error* message returned.
217 (define (reply-message from-actor original-message
220 (set-message-replied! original-message #t)
221 (let* ((hive (actor-hive from-actor))
222 (new-message (make-message (hive-gen-message-id hive)
223 (message-from original-message)
224 (actor-id from-actor) '*reply*
225 (kwarg-list-to-alist message-body-args)
226 #:in-reply-to (message-id original-message))))
227 (8sync (hive-process-message hive new-message))))
229 (define (reply-message-wait from-actor original-message
231 "Reply to a messsage, but wait until we get a response"
232 (set-message-replied! original-message #t)
233 (let* ((hive (actor-hive from-actor))
234 (abort-to (hive-prompt (actor-hive from-actor)))
235 (new-message (make-message (hive-gen-message-id hive)
236 (message-from original-message)
237 (actor-id from-actor) '*reply*
238 (kwarg-list-to-alist message-body-args)
240 #:in-reply-to (message-id original-message))))
241 (abort-to-prompt abort-to from-actor new-message)))
245 ;;; See: http://mumble.net/~jar/articles/oo-moon-weinreb.html
246 ;;; (also worth seeing: http://mumble.net/~jar/articles/oo.html )
248 (define <- send-message)
249 (define <-wait send-message-wait)
250 (define <-reply reply-message)
251 (define <-reply-wait reply-message-wait)
255 ;;; Main actor implementation
256 ;;; =========================
258 (define-class <actor> ()
260 (id #:init-keyword #:id
262 ;; The hive we're connected to.
263 ;; We need this to be able to send messages.
264 (hive #:init-keyword #:hive
265 #:accessor actor-hive)
266 ;; How we receive and process new messages
267 (message-handler #:allocation #:each-subclass))
269 (define-method (actor-message-handler (actor <actor>))
270 (slot-ref actor 'message-handler))
272 ;;; So these are the nicer representations of addresses.
273 ;;; However, they don't serialize so easily with scheme read/write, so we're
274 ;;; using the simpler cons cell version below for now.
276 ;; (define-record-type <address>
277 ;; (make-address actor-id hive-id) ; @@: Do we want the trailing -id?
279 ;; (actor-id address-actor-id)
280 ;; (hive-id address-hive-id))
282 ;; (set-record-type-printer!
284 ;; (lambda (record port)
285 ;; (format port "<address: ~s@~s>"
286 ;; (address-actor-id record) (address-hive-id record))))
289 (define (make-address actor-id hive-id)
290 (cons actor-id hive-id))
292 (define (address-actor-id address)
295 (define (address-hive-id address)
298 (define (address->string address)
299 (string-append (address-actor-id address) "@"
300 (address-hive-id address)))
302 (define-method (actor-id-actor (actor <actor>))
303 "Get the actor id component of the actor-id"
304 (address-actor-id (actor-id actor)))
306 (define-method (actor-id-hive (actor <actor>))
307 "Get the hive id component of the actor-id"
308 (address-hive-id (actor-id actor)))
310 (define-method (actor-id-string (actor <actor>))
311 "Render the full actor id as a human-readable string"
312 (address->string (actor-id actor)))
320 (define-syntax-rule (with-message-args (message message-arg ...)
322 (let ((message-arg (message-ref message (quote message-arg))) ...)
325 (define-syntax mlambda
327 "A lambda for building message handlers.
330 (mlambda (actor message foo)
333 Which is like doing manually:
334 (lambda (actor message)
335 (let ((foo (message-ref message foo)))
338 ((_ (actor message message-arg ...)
341 (string? (syntax->datum #'docstring))
342 #'(lambda (actor message)
344 (with-message-args (message message-arg ...) body ...)))
345 ((_ (actor message message-arg ...)
347 #'(lambda (actor message)
348 (with-message-args (message message-arg ...) body body* ...))))))
350 (define-syntax-rule (define-mhandler (name actor message message-arg ...)
353 (mlambda (actor message message-arg ...)
356 (define (simple-dispatcher action-map)
357 (lambda (actor message)
358 (let* ((action (message-action message))
359 (method (assoc-ref action-map action)))
361 ;; @@: There's every possibility this should be handled in
362 ;; hive-process-message instead.
363 (throw 'action-not-found
364 "No appropriate action handler found for actor"
368 #:available-actions (map car action-map)))
369 (method actor message))))
371 (define-syntax %expand-action-item
373 ((_ ((action-name action-args ...) body ...))
374 (cons (quote action-name)
375 (mlambda (action-args ...)
377 ((_ (action-name handler))
378 (cons (quote action-name) handler))))
380 (define-syntax-rule (build-actions action-item ...)
381 "Build a mapping of actions. Same syntax as make-action-dispatch
382 but this doesn't build the dispatcher for you (you probably want to
383 pass it to simple-dispatcher).
385 The advantage here is that since this simply builds an alist, you can
386 compose it with other action maps."
387 (list (%expand-action-item action-item) ...))
389 (define-syntax make-action-dispatch
391 "Expand a list of action names and actions into an alist
393 You can use this like the following:
394 (make-action-dispatch
396 (lambda (actor message)
397 (display \"I love cookies!\n\")))
399 (lambda (actor message)
400 (display \"Life of the party!\"))))
402 Alternately, if you'd like to skip the lambda, you could use the slightly
403 more compact following syntax:
404 (make-action-dispatch
405 ((cookies actor message)
406 (display \"I love cookies!\n\"))
407 ((party actor message)
408 (display \"Life of the party!\")))"
409 ((make-action-dispatch action-item ...)
410 (simple-dispatcher (build-actions action-item ...)))))
412 (define-syntax-rule (define-simple-actor class actions ...)
413 (define-class class (<actor>)
415 #:init-value (make-action-dispatch actions ...)
416 #:allocation #:each-subclass)))
421 ;;; Every actor has a hive. The hive is a kind of "meta-actor"
422 ;;; which routes all the rest of the actors in a system.
424 (define-generic hive-handle-failed-forward)
426 (define-class <hive> (<actor>)
427 (actor-registry #:init-thunk make-hash-table
428 #:getter hive-actor-registry)
429 (msg-id-generator #:init-thunk simple-message-id-generator
430 #:getter hive-msg-id-generator)
431 ;; Ambassadors are used (or will be) for inter-hive communication.
432 ;; These are special actors that know how to route messages to other hives.
433 (ambassadors #:init-thunk make-weak-key-hash-table
434 #:getter hive-ambassadors)
435 ;; Waiting coroutines
436 ;; This is a map from cons cell of message-id
437 ;; to a cons cell of (actor-id . coroutine)
438 ;; @@: Should we have a <waiting-coroutine> record type?
439 ;; @@: Should there be any way to clear out "old" coroutines?
440 (waiting-coroutines #:init-thunk make-hash-table
441 #:getter hive-waiting-coroutines)
443 ;; When actors send messages to each other they abort to this prompt
444 ;; to send the message, then carry on their way
445 (prompt #:init-thunk make-prompt-tag
446 #:getter hive-prompt)
449 (make-action-dispatch
450 ;; This is in the case of an ambassador failing to forward a message...
451 ;; it reports it back to the hive
452 (*failed-forward* hive-handle-failed-forward))))
454 (define-method (hive-handle-failed-forward (hive <hive>) message)
455 "Handle an ambassador failing to forward a message"
458 (define* (make-hive #:key hive-id)
459 (let ((hive (make <hive>
462 (big-random-number-string))))))
463 ;; Set the hive's actor reference to itself
464 (set! (actor-hive hive) hive)
467 (define-method (hive-id (hive <hive>))
468 (actor-id-hive hive))
470 (define-method (hive-gen-actor-id (hive <hive>) cookie)
471 (make-address (if cookie
472 (string-append cookie "-" (big-random-number-string))
473 (big-random-number-string))
476 (define-method (hive-gen-message-id (hive <hive>))
477 "Generate a message id using HIVE's message id generator"
478 ((hive-msg-id-generator hive)))
480 (define-method (hive-resolve-local-actor (hive <hive>) actor-address)
481 (hash-ref (hive-actor-registry hive) actor-address))
483 (define-method (hive-resolve-ambassador (hive <hive>) ambassador-address)
484 (hash-ref (hive-ambassadors hive) ambassador-address))
486 (define-method (make-forward-request (hive <hive>) (ambassador <actor>) message)
487 (make-message (hive-gen-message-id hive) (actor-id ambassador)
488 ;; If we make the hive not an actor, we could either switch this
489 ;; to #f or to the original actor...?
490 ;; Maybe some more thinking should be done on what should
491 ;; happen in case of failure to forward? Handling ambassador failures
492 ;; seems like the primary motivation for the hive remaining an actor.
495 `((original . ,message))))
497 (define-method (hive-reply-with-error (hive <hive>) original-message
498 error-key error-args)
499 ;; We only supply the error-args if the original sender is on the same hive
500 (define (orig-actor-on-same-hive?)
501 (equal? (hive-id hive)
502 (address-hive-id (message-from original-message))))
503 (set-message-replied! original-message #t)
504 (let* ((new-message-body
505 (if (orig-actor-on-same-hive?)
506 `((original-message . ,original-message)
507 (error-key . ,error-key)
508 (error-args . ,error-args))
509 `((original-message . ,original-message)
510 (error-key . ,error-key))))
511 (new-message (make-message (hive-gen-message-id hive)
512 (message-from original-message)
513 (actor-id hive) '*error*
515 #:in-reply-to (message-id original-message))))
516 (8sync (hive-process-message hive new-message))))
518 (define-method (hive-process-message (hive <hive>) message)
519 "Handle one message, or forward it via an ambassador"
520 (define (maybe-autoreply actor)
521 ;; Possibly autoreply
522 (if (message-needs-reply message)
523 ;; @@: Should we give *autoreply* as the action instead of *reply*?
524 (reply-message actor message
527 (define (resolve-actor-to)
528 "Get the actor the message was aimed at"
529 (let ((actor (hive-resolve-local-actor hive (message-to message))))
531 (throw 'actor-not-found
532 (format #f "Message ~a from ~a directed to nonexistant actor ~a"
534 (address->string (message-from message))
535 (address->string (message-to message)))
539 (define (call-catching-coroutine thunk)
540 (define (call-catching-errors)
541 ;; TODO: maybe parameterize (or attach to hive) and use
542 ;; maybe-catch-all from agenda.scm
543 ;; @@: Why not just use with-throw-handler and let the catch
544 ;; happen at the agenda? That's what we used to do, but
545 ;; it ended up with a SIGABRT. See:
546 ;; http://lists.gnu.org/archive/html/bug-guile/2016-05/msg00003.html
549 ;; In the actor model, we don't totally crash on errors.
551 ;; If an error happens, we raise it
553 (if (message-needs-reply message)
554 ;; If the message is waiting on a reply, let them know
555 ;; something went wrong.
556 (hive-reply-with-error hive message key args))
557 ;; print error message
558 (apply print-error-and-continue key args))))
559 (call-with-prompt (hive-prompt hive)
561 (lambda (kont actor message)
562 ;; Register the coroutine
563 (hash-set! (hive-waiting-coroutines hive)
565 (cons (actor-id actor) kont))
566 ;; Send off the message
567 (8sync (hive-process-message hive message)))))
569 (define (process-local-message)
570 (let ((actor (resolve-actor-to)))
571 (call-catching-coroutine
573 (define message-handler (actor-message-handler actor))
574 ;; @@: Should a more general error handling happen here?
576 (message-handler actor message)))
577 (maybe-autoreply actor)
578 ;; Returning result allows actors to possibly make a run-request
579 ;; at the end of handling a message.
580 ;; ... We do want that, right?
583 (define (resume-waiting-coroutine)
585 ((eq? (message-action message) '*reply*)
586 (call-catching-coroutine
588 (match (hash-remove! (hive-waiting-coroutines hive)
589 (message-in-reply-to message))
590 ((_ . (resume-actor-id . kont))
591 (if (not (equal? (message-to message)
593 (throw 'resuming-to-wrong-actor
594 "Attempted to resume a coroutine to the wrong actor!"
595 #:expected-actor-id (message-to message)
596 #:got-actor-id resume-actor-id
598 (let (;; @@: How should we resolve resuming coroutines to actors who are
600 (actor (resolve-actor-to))
601 (result (kont message)))
602 (maybe-autoreply actor)
604 (#f (throw 'no-waiting-coroutine
605 "message in-reply-to tries to resume nonexistent coroutine"
607 ;; Yikes, we must have gotten an error or something back
609 ;; @@: Not what we want in the long run?
610 ;; What we'd *prefer* to do is to resume this message
611 ;; and throw an error inside the message handler
612 ;; (say, from send-mesage-wait), but that causes a SIGABRT (??!!)
613 (hash-remove! (hive-waiting-coroutines hive)
614 (message-in-reply-to message))
616 (if (eq? (message-action message) '*reply*)
617 "Won't resume coroutine; got an *error* as a reply"
618 "Won't resume coroutine because action is not *reply*")))
619 (throw 'hive-unresumable-coroutine
621 #:message message)))))
623 (define (process-remote-message)
624 ;; Find the ambassador
625 (let* ((remote-hive-id (hive-id (message-to message)))
626 (ambassador (hive-resolve-ambassador remote-hive-id))
627 (message-handler (actor-message-handler ambassador))
628 (forward-request (make-forward-request hive ambassador message)))
629 (message-handler ambassador forward-request)))
631 (let ((to (message-to message)))
632 ;; This seems to be an easy mistake to make, so check that addressing
635 (throw 'missing-addressee
636 "`to' field is missing on message"
638 (if (hive-actor-local? hive to)
639 (if (message-in-reply-to message)
640 (resume-waiting-coroutine)
641 (process-local-message))
642 (process-remote-message))))
644 (define-method (hive-actor-local? (hive <hive>) address)
645 (equal? (hive-id hive) (address-hive-id address)))
647 (define-method (hive-register-actor! (hive <hive>) (actor <actor>))
648 (hash-set! (hive-actor-registry hive) (actor-id actor) actor))
650 (define-method (%hive-create-actor (hive <hive>) actor-class
652 "Actual method called by hive-create-actor.
654 Since this is a define-method it can't accept fancy define* arguments,
655 so this gets called from the nicer hive-create-actor interface. See
656 that method for documentation."
657 (let* ((actor-id (hive-gen-actor-id hive id-cookie))
658 (actor (apply make actor-class
662 (hive-register-actor! hive actor)
663 ;; return the actor id
666 (define* (hive-create-actor hive actor-class #:rest init)
667 (%hive-create-actor hive actor-class
670 (define* (hive-create-actor* hive actor-class id-cookie #:rest init)
671 (%hive-create-actor hive actor-class
676 ;;; Various API methods for actors to interact with the system
677 ;;; ==========================================================
679 ;; TODO: move send-message and friends here...?
681 (define* (create-actor from-actor actor-class #:rest init)
682 "Create an instance of actor-class. Return the new actor's id.
684 This is the method actors should call directly (unless they want
685 to supply an id-cookie, in which case they should use
687 (8sync (%hive-create-actor (actor-hive from-actor) actor-class
691 (define* (create-actor* from-actor actor-class id-cookie #:rest init)
692 "Create an instance of actor-class. Return the new actor's id.
694 Like create-actor, but permits supplying an id-cookie."
695 (8sync (%hive-create-actor (actor-hive from-actor) actor-class
699 (define (self-destruct actor)
700 "Remove an actor from the hive."
701 (hash-remove! (hive-actor-registry (actor-hive actor))
706 ;;; 8sync bootstrap utilities
707 ;;; =========================
709 (define* (ez-run-hive hive initial-tasks #:key repl-server)
710 "Start up an agenda and run HIVE in it with INITIAL-TASKS.
712 Should we start up a cooperative REPL for live hacking? REPL-SERVER
713 wants to know! You can pass it #t or #f, or if you want to specify a port,
715 (let* ((queue (list->q initial-tasks))
716 (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
719 ;; If repl-server is an integer, we'll use that as the port
720 ((integer? repl-server)
721 (spawn-and-queue-repl-server! agenda repl-server))
723 (spawn-and-queue-repl-server! agenda)))
724 (start-agenda agenda)))
726 (define (bootstrap-message hive to-id action . message-body-args)
728 (apply send-message hive to-id action message-body-args)))
732 ;;; Basic readers / writers
733 ;;; =======================
735 (define (serialize-message message)
736 "Serialize a message for read/write"
740 (message-from message)
741 (message-action message)
742 (message-body message)
743 (message-in-reply-to message)
744 (message-wants-reply message)
745 (message-replied message)
746 (message-deferred-reply message)))
748 (define* (write-message message #:optional (port (current-output-port)))
749 "Write out a message to a port for easy reading later.
751 Note that if a sub-value can't be easily written to something
752 Guile's `read' procedure knows how to read, this doesn't do anything
753 to improve that. You'll need a better serializer for that.."
754 (write (serialize-message message) port))
756 (define (serialize-message-pretty message)
757 "Serialize a message in a way that's easy for humans to read."
759 (id ,(message-id message))
760 (to ,(message-to message))
761 (from ,(message-from message))
762 (action ,(message-action message))
763 (body ,(message-body message))
764 (in-reply-to ,(message-in-reply-to message))
765 (wants-reply ,(message-wants-reply message))
766 (replied ,(message-replied message))
767 (deferred-reply ,(message-deferred-reply message))))
769 (define (pprint-message message)
770 "Pretty print a message."
771 (pretty-print (serialize-message-pretty message)))
773 (define* (read-message #:optional (port (current-input-port)))
774 "Read a message serialized via serialize-message from PORT"
776 ((id to from action body in-reply-to wants-reply replied deferred-reply)
778 id to from action body
779 in-reply-to wants-reply replied deferred-reply))
781 (throw 'message-read-bad-structure
782 "Could not read message from structure"
785 (define (read-message-from-string message-str)
786 "Read message from MESSAGE-STR"
787 (with-input-from-string message-str
789 (read-message (current-input-port)))))