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 control)
26 #:use-module (ice-9 format)
27 #:use-module (ice-9 match)
28 #:use-module (ice-9 pretty-print)
29 #:use-module (8sync agenda)
30 #:use-module (8sync repl)
31 #:export (;; utilities... ought to go in their own module
33 big-random-number-string
34 simple-message-id-generator
42 ;;; Commenting out the <address> type for now;
43 ;;; it may be back when we have better serializers
46 address-actor-id address-hive-id
53 simple-dispatcher build-actions make-action-dispatch
60 ;; There are more methods for the hive, but there's
61 ;; no reason for the outside world to look at them maybe?
63 hive-create-actor hive-create-actor*
65 create-actor create-actor*
70 message-to message-action message-from
71 message-id message-body message-in-reply-to
76 <- <-wait <-reply <-reply-wait
78 call-with-message msg-receive msg-val
83 serialize-message write-message
84 serialize-message-pretty pprint-message
85 read-message read-message-from-string))
89 (make-parameter (random-state-from-platform)))
91 ;; Same size as a uuid4 I think...
92 (define random-number-size (expt 2 128))
94 (define (big-random-number)
95 (random random-number-size (%random-state)))
97 ;; Would be great to get this base64 encoded instead.
98 (define (big-random-number-string)
99 ;; @@: This is slow. Using format here is wasteful.
100 (format #f "~x" (big-random-number)))
102 ;; @@: This is slow. A mere ~275k / second on my (old) machine.
103 ;; The main cost seems to be in number->string.
104 (define (simple-message-id-generator)
105 ;; Prepending this cookie makes message ids unique per hive
106 (let ((prefix (format #f "~x:" (big-random-number)))
109 (set! counter (1+ counter))
110 (string-append prefix (number->string counter)))))
118 ;; @@: We may want to add a deferred-reply to the below, similar to
119 ;; what we had in XUDD, for actors which do their own response
120 ;; queueing.... ie, that might receive messages but need to shelve
121 ;; them to be acted upon after something else is taken care of.
123 (define-record-type <message>
124 (make-message-intern id to from action
125 body in-reply-to wants-reply
131 (action message-action)
133 (in-reply-to message-in-reply-to)
134 (wants-reply message-wants-reply)
135 (replied message-replied set-message-replied!))
138 (define* (make-message id to from action body
139 #:key in-reply-to wants-reply
141 (make-message-intern id to from action body
142 in-reply-to wants-reply replied))
144 (define (message-auto-reply? message)
145 (eq? (message-action message) '*auto-reply*))
147 (define (message-needs-reply? message)
148 "See if this message needs a reply still"
149 (and (message-wants-reply message)
150 (not (message-replied message))))
153 (define (kwarg-list-to-alist args)
154 (let loop ((remaining args)
157 (((? keyword? key) val rest ...)
159 (cons (cons (keyword->symbol key) val)
162 (_ (throw 'invalid-kwarg-list
163 "Invalid keyword argument list"
167 ;;; See: https://web.archive.org/web/20081223021934/http://mumble.net/~jar/articles/oo-moon-weinreb.html
168 ;;; (also worth seeing: http://mumble.net/~jar/articles/oo.html )
170 (define (<- from-actor to-id action . message-body-args)
171 "Send a message from an actor to another actor"
172 (let* ((hive (actor-hive from-actor))
173 (message (make-message (hive-gen-message-id hive) to-id
174 (actor-id from-actor) action
176 (8sync (hive-process-message hive message))))
178 (define (<-wait from-actor to-id action . message-body-args)
179 "Send a message from an actor to another, but wait until we get a response"
180 (let* ((hive (actor-hive from-actor))
181 (abort-to (hive-prompt (actor-hive from-actor)))
182 (message (make-message (hive-gen-message-id hive) to-id
183 (actor-id from-actor) action
186 (abort-to-prompt abort-to from-actor message)))
188 ;; TODO: Intelligently ~propagate(ish) errors on -wait functions.
189 ;; We might have `send-message-wait-brazen' to allow callers to
190 ;; not have an exception thrown and instead just have a message with
191 ;; the appropriate '*error* message returned.
193 (define (<-reply from-actor original-message . message-body-args)
195 (set-message-replied! original-message #t)
196 (let* ((hive (actor-hive from-actor))
197 (new-message (make-message (hive-gen-message-id hive)
198 (message-from original-message)
199 (actor-id from-actor) '*reply*
201 #:in-reply-to (message-id original-message))))
202 (8sync (hive-process-message hive new-message))))
204 (define (<-auto-reply from-actor original-message)
205 "Auto-reply to a message. Internal use only!"
206 (set-message-replied! original-message #t)
207 (let* ((hive (actor-hive from-actor))
208 (new-message (make-message (hive-gen-message-id hive)
209 (message-from original-message)
210 (actor-id from-actor) '*auto-reply*
212 #:in-reply-to (message-id original-message))))
213 (8sync (hive-process-message hive new-message))))
215 (define (<-reply-wait from-actor original-message . message-body-args)
216 "Reply to a messsage, but wait until we get a response"
217 (set-message-replied! original-message #t)
218 (let* ((hive (actor-hive from-actor))
219 (abort-to (hive-prompt (actor-hive from-actor)))
220 (new-message (make-message (hive-gen-message-id hive)
221 (message-from original-message)
222 (actor-id from-actor) '*reply*
225 #:in-reply-to (message-id original-message))))
226 (abort-to-prompt abort-to from-actor new-message)))
230 ;;; Main actor implementation
231 ;;; =========================
233 (define (actor-inheritable-message-handler actor message)
234 (define action (message-action message))
235 (define (find-message-handler return)
236 (for-each (lambda (this-class)
238 (or (and (class-slot-definition this-class 'actions)
239 (class-slot-ref this-class 'actions))
241 (for-each (match-lambda
242 ((action-name . method)
243 (when (eq? action-name action)
246 (class-precedence-list (class-of actor)))
247 (throw 'action-not-found
248 "No appropriate action handler found for actor"
253 (call/ec find-message-handler))
254 (apply method actor message (message-body message)))
256 (define-class <actor> ()
258 (id #:init-keyword #:id
260 ;; The hive we're connected to.
261 ;; We need this to be able to send messages.
262 (hive #:init-keyword #:hive
263 #:accessor actor-hive)
264 ;; How we receive and process new messages
265 (message-handler #:init-value actor-inheritable-message-handler
266 ;; @@: There's no reason not to use #:class instead of
267 ;; #:each-subclass anywhere in this file, except for
268 ;; Guile bug #25211 (#:class is broken in Guile 2.2)
269 #:allocation #:each-subclass)
271 ;; This is the default, "simple" way to inherit and process messages.
272 (actions #:init-value '()
273 #:allocation #:each-subclass))
275 (define-method (actor-message-handler (actor <actor>))
276 (slot-ref actor 'message-handler))
278 ;;; So these are the nicer representations of addresses.
279 ;;; However, they don't serialize so easily with scheme read/write, so we're
280 ;;; using the simpler cons cell version below for now.
282 ;; (define-record-type <address>
283 ;; (make-address actor-id hive-id) ; @@: Do we want the trailing -id?
285 ;; (actor-id address-actor-id)
286 ;; (hive-id address-hive-id))
288 ;; (set-record-type-printer!
290 ;; (lambda (record port)
291 ;; (format port "<address: ~s@~s>"
292 ;; (address-actor-id record) (address-hive-id record))))
295 (define (make-address actor-id hive-id)
296 (cons actor-id hive-id))
298 (define (address-actor-id address)
301 (define (address-hive-id address)
304 (define (address->string address)
305 (string-append (address-actor-id address) "@"
306 (address-hive-id address)))
308 (define-method (actor-id-actor (actor <actor>))
309 "Get the actor id component of the actor-id"
310 (address-actor-id (actor-id actor)))
312 (define-method (actor-id-hive (actor <actor>))
313 "Get the hive id component of the actor-id"
314 (address-hive-id (actor-id actor)))
316 (define-method (actor-id-string (actor <actor>))
317 "Render the full actor id as a human-readable string"
318 (address->string (actor-id actor)))
320 (define %current-actor
328 ;;;;;;;;;;; Deprecated abstractions start here ;;;;;;;;;;;
330 (define (simple-dispatcher action-map)
331 (lambda (actor message)
332 (let* ((action (message-action message))
333 (method (assoc-ref action-map action)))
335 ;; @@: There's every possibility this should be handled in
336 ;; hive-process-message instead.
337 (throw 'action-not-found
338 "No appropriate action handler found for actor"
342 #:available-actions (map car action-map)))
343 (apply method actor message (message-body message)))))
345 (define-syntax %expand-action-item
347 ((_ (action-name handler))
348 (cons (quote action-name) handler))))
350 (define-syntax-rule (build-actions action-item ...)
351 "Build a mapping of actions. Same syntax as make-action-dispatch
352 but this doesn't build the dispatcher for you (you probably want to
353 pass it to simple-dispatcher).
355 The advantage here is that since this simply builds an alist, you can
356 compose it with other action maps."
357 (list (%expand-action-item action-item) ...))
359 (define-syntax make-action-dispatch
361 "Expand a list of action names and actions into an alist
363 You can use this like the following:
364 (make-action-dispatch
366 (lambda (actor message)
367 (display \"I love cookies!\n\")))
369 (lambda (actor message)
370 (display \"Life of the party!\"))))
372 Alternately, if you'd like to skip the lambda, you could use the slightly
373 more compact following syntax:
374 (make-action-dispatch
375 ((cookies actor message)
376 (display \"I love cookies!\n\"))
377 ((party actor message)
378 (display \"Life of the party!\")))"
379 ((make-action-dispatch action-item ...)
380 (simple-dispatcher (build-actions action-item ...)))))
382 ;;;;;;;;;;; Deprecated abstractions end here ;;;;;;;;;;;
385 (define-syntax-rule (mhandlers (symbol method) ...)
386 "Construct an alist of (symbol . method), where the method is wrapped
387 with wrap-apply to facilitate live hacking and allow the method definition
388 to come after class definition."
391 (wrap-apply method)) ...))
393 (define-syntax-rule (define-simple-actor class action ...)
394 (define-class class (<actor>)
395 (actions #:init-value (mhandlers action ...)
396 #:allocation #:each-subclass)))
401 ;;; Every actor has a hive. The hive is a kind of "meta-actor"
402 ;;; which routes all the rest of the actors in a system.
404 (define-generic hive-handle-failed-forward)
406 (define-class <hive> (<actor>)
407 (actor-registry #:init-thunk make-hash-table
408 #:getter hive-actor-registry)
409 (msg-id-generator #:init-thunk simple-message-id-generator
410 #:getter hive-msg-id-generator)
411 ;; Ambassadors are used (or will be) for inter-hive communication.
412 ;; These are special actors that know how to route messages to other hives.
413 (ambassadors #:init-thunk make-weak-key-hash-table
414 #:getter hive-ambassadors)
415 ;; Waiting coroutines
416 ;; This is a map from cons cell of message-id
417 ;; to a cons cell of (actor-id . coroutine)
418 ;; @@: Should we have a <waiting-coroutine> record type?
419 ;; @@: Should there be any way to clear out "old" coroutines?
420 (waiting-coroutines #:init-thunk make-hash-table
421 #:getter hive-waiting-coroutines)
423 ;; When actors send messages to each other they abort to this prompt
424 ;; to send the message, then carry on their way
425 (prompt #:init-thunk make-prompt-tag
426 #:getter hive-prompt)
429 (make-action-dispatch
430 ;; This is in the case of an ambassador failing to forward a message...
431 ;; it reports it back to the hive
432 (*failed-forward* hive-handle-failed-forward))))
434 (define-method (hive-handle-failed-forward (hive <hive>) message)
435 "Handle an ambassador failing to forward a message"
438 (define* (make-hive #:key hive-id)
439 (let ((hive (make <hive>
442 (big-random-number-string))))))
443 ;; Set the hive's actor reference to itself
444 (set! (actor-hive hive) hive)
447 (define-method (hive-id (hive <hive>))
448 (actor-id-hive hive))
450 (define-method (hive-gen-actor-id (hive <hive>) cookie)
451 (make-address (if cookie
452 (string-append cookie "-" (big-random-number-string))
453 (big-random-number-string))
456 (define-method (hive-gen-message-id (hive <hive>))
457 "Generate a message id using HIVE's message id generator"
458 ((hive-msg-id-generator hive)))
460 (define-method (hive-resolve-local-actor (hive <hive>) actor-address)
461 (hash-ref (hive-actor-registry hive) actor-address))
463 (define-method (hive-resolve-ambassador (hive <hive>) ambassador-address)
464 (hash-ref (hive-ambassadors hive) ambassador-address))
466 (define-method (make-forward-request (hive <hive>) (ambassador <actor>) message)
467 (make-message (hive-gen-message-id hive) (actor-id ambassador)
468 ;; If we make the hive not an actor, we could either switch this
469 ;; to #f or to the original actor...?
470 ;; Maybe some more thinking should be done on what should
471 ;; happen in case of failure to forward? Handling ambassador failures
472 ;; seems like the primary motivation for the hive remaining an actor.
475 `((original . ,message))))
477 (define-method (hive-reply-with-error (hive <hive>) original-message
478 error-key error-args)
479 ;; We only supply the error-args if the original sender is on the same hive
480 (define (orig-actor-on-same-hive?)
481 (equal? (hive-id hive)
482 (address-hive-id (message-from original-message))))
483 (set-message-replied! original-message #t)
484 (let* ((new-message-body
485 (if (orig-actor-on-same-hive?)
486 `(#:original-message ,original-message
487 #:error-key ,error-key
488 #:error-args ,error-args)
489 `(#:original-message ,original-message
490 #:error-key ,error-key)))
491 (new-message (make-message (hive-gen-message-id hive)
492 (message-from original-message)
493 (actor-id hive) '*error*
495 #:in-reply-to (message-id original-message))))
496 ;; We only return a thunk, rather than run 8sync here, because if
497 ;; we ran 8sync in the middle of a catch we'd end up with an
498 ;; unresumable continuation.
499 (lambda () (hive-process-message hive new-message))))
501 (define-method (hive-process-message (hive <hive>) message)
502 "Handle one message, or forward it via an ambassador"
503 (define (maybe-autoreply actor)
504 ;; Possibly autoreply
505 (if (message-needs-reply? message)
506 (<-auto-reply actor message)))
508 (define (resolve-actor-to)
509 "Get the actor the message was aimed at"
510 (let ((actor (hive-resolve-local-actor hive (message-to message))))
512 (throw 'actor-not-found
513 (format #f "Message ~a from ~a directed to nonexistant actor ~a"
515 (address->string (message-from message))
516 (address->string (message-to message)))
520 (define (call-catching-coroutine thunk)
521 (define queued-error-handling-thunk #f)
522 (define (call-catching-errors)
523 ;; TODO: maybe parameterize (or attach to hive) and use
524 ;; maybe-catch-all from agenda.scm
525 ;; @@: Why not just use with-throw-handler and let the catch
526 ;; happen at the agenda? That's what we used to do, but
527 ;; it ended up with a SIGABRT. See:
528 ;; http://lists.gnu.org/archive/html/bug-guile/2016-05/msg00003.html
531 ;; In the actor model, we don't totally crash on errors.
533 ;; If an error happens, we raise it
535 (if (message-needs-reply? message)
536 ;; If the message is waiting on a reply, let them know
537 ;; something went wrong.
538 ;; However, we have to do it outside of this catch
539 ;; routine, or we'll end up in an unrewindable continuation
541 (set! queued-error-handling-thunk
542 (hive-reply-with-error hive message key args)))
543 ;; print error message
544 (apply print-error-and-continue key args)))
545 ;; @@: This is a kludge. See above for why.
546 (if queued-error-handling-thunk
547 (8sync (queued-error-handling-thunk))))
548 (call-with-prompt (hive-prompt hive)
550 (lambda (kont actor message)
551 ;; Register the coroutine
552 (hash-set! (hive-waiting-coroutines hive)
554 (cons (actor-id actor) kont))
555 ;; Send off the message
556 (8sync (hive-process-message hive message)))))
558 (define (process-local-message)
559 (let ((actor (resolve-actor-to)))
560 (call-catching-coroutine
562 (define message-handler (actor-message-handler actor))
563 ;; @@: Should a more general error handling happen here?
564 (parameterize ((%current-actor actor))
566 (message-handler actor message)))
567 (maybe-autoreply actor)
568 ;; Returning result allows actors to possibly make a run-request
569 ;; at the end of handling a message.
570 ;; ... We do want that, right?
573 (define (resume-waiting-coroutine)
575 ((or (eq? (message-action message) '*reply*)
576 (eq? (message-action message) '*auto-reply*))
577 (call-catching-coroutine
579 (match (hash-remove! (hive-waiting-coroutines hive)
580 (message-in-reply-to message))
581 ((_ . (resume-actor-id . kont))
582 (if (not (equal? (message-to message)
584 (throw 'resuming-to-wrong-actor
585 "Attempted to resume a coroutine to the wrong actor!"
586 #:expected-actor-id (message-to message)
587 #:got-actor-id resume-actor-id
589 (let (;; @@: How should we resolve resuming coroutines to actors who are
591 (actor (resolve-actor-to))
592 (result (kont message)))
593 (maybe-autoreply actor)
595 (#f (throw 'no-waiting-coroutine
596 "message in-reply-to tries to resume nonexistent coroutine"
598 ;; Yikes, we must have gotten an error or something back
600 ;; @@: Not what we want in the long run?
601 ;; What we'd *prefer* to do is to resume this message
602 ;; and throw an error inside the message handler
603 ;; (say, from send-mesage-wait), but that causes a SIGABRT (??!!)
604 (hash-remove! (hive-waiting-coroutines hive)
605 (message-in-reply-to message))
607 (if (eq? (message-action message) '*reply*)
608 "Won't resume coroutine; got an *error* as a reply"
609 "Won't resume coroutine because action is not *reply*")))
610 (throw 'hive-unresumable-coroutine
612 #:message message)))))
614 (define (process-remote-message)
615 ;; Find the ambassador
616 (let* ((remote-hive-id (hive-id (message-to message)))
617 (ambassador (hive-resolve-ambassador remote-hive-id))
618 (message-handler (actor-message-handler ambassador))
619 (forward-request (make-forward-request hive ambassador message)))
620 (message-handler ambassador forward-request)))
622 (let ((to (message-to message)))
623 ;; This seems to be an easy mistake to make, so check that addressing
626 (throw 'missing-addressee
627 "`to' field is missing on message"
629 (if (hive-actor-local? hive to)
630 (if (message-in-reply-to message)
631 (resume-waiting-coroutine)
632 (process-local-message))
633 (process-remote-message))))
635 (define-method (hive-actor-local? (hive <hive>) address)
636 (equal? (hive-id hive) (address-hive-id address)))
638 (define-method (hive-register-actor! (hive <hive>) (actor <actor>))
639 (hash-set! (hive-actor-registry hive) (actor-id actor) actor))
641 (define-method (%hive-create-actor (hive <hive>) actor-class
643 "Actual method called by hive-create-actor.
645 Since this is a define-method it can't accept fancy define* arguments,
646 so this gets called from the nicer hive-create-actor interface. See
647 that method for documentation."
648 (let* ((actor-id (hive-gen-actor-id hive id-cookie))
649 (actor (apply make actor-class
653 (hive-register-actor! hive actor)
654 ;; return the actor id
657 (define* (hive-create-actor hive actor-class #:rest init)
658 (%hive-create-actor hive actor-class
661 (define* (hive-create-actor* hive actor-class id-cookie #:rest init)
662 (%hive-create-actor hive actor-class
665 (define (call-with-message message proc)
666 "Applies message body arguments into procedure, with message as first
667 argument. Similar to call-with-values in concept."
668 (apply proc message (message-body message)))
670 ;; (msg-receive (<- bar baz)
674 ;; Emacs: (put 'msg-receive 'scheme-indent-function 2)
676 ;; @@: Or receive-msg or receieve-message or??
677 (define-syntax-rule (msg-receive arglist message body ...)
678 "Call body with arglist (which can accept arguments like lambda*)
679 applied from the message-body of message."
680 (call-with-message message
684 (define (msg-val message)
685 "Retrieve the first value from the message-body of message.
686 Like single value return from a procedure call. Probably the most
687 common case when waiting on a reply from some action invocation."
688 (call-with-message message
689 (lambda (_ val) val)))
692 ;;; Various API methods for actors to interact with the system
693 ;;; ==========================================================
695 ;; TODO: move send-message and friends here...?
697 (define* (create-actor from-actor actor-class #:rest init)
698 "Create an instance of actor-class. Return the new actor's id.
700 This is the method actors should call directly (unless they want
701 to supply an id-cookie, in which case they should use
703 (%hive-create-actor (actor-hive from-actor) actor-class
707 (define* (create-actor* from-actor actor-class id-cookie #:rest init)
708 "Create an instance of actor-class. Return the new actor's id.
710 Like create-actor, but permits supplying an id-cookie."
711 (%hive-create-actor (actor-hive from-actor) actor-class
715 (define (self-destruct actor)
716 "Remove an actor from the hive."
717 (hash-remove! (hive-actor-registry (actor-hive actor))
722 ;;; 8sync bootstrap utilities
723 ;;; =========================
725 (define* (ez-run-hive hive initial-tasks #:key repl-server)
726 "Start up an agenda and run HIVE in it with INITIAL-TASKS.
728 Should we start up a cooperative REPL for live hacking? REPL-SERVER
729 wants to know! You can pass it #t or #f, or if you want to specify a port,
731 (let* ((queue (list->q initial-tasks))
732 (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
735 ;; If repl-server is an integer, we'll use that as the port
736 ((integer? repl-server)
737 (spawn-and-queue-repl-server! agenda repl-server))
739 (spawn-and-queue-repl-server! agenda)))
740 (start-agenda agenda)))
742 (define (bootstrap-message hive to-id action . message-body-args)
744 (apply <- hive to-id action message-body-args)))
748 ;;; Basic readers / writers
749 ;;; =======================
751 (define (serialize-message message)
752 "Serialize a message for read/write"
756 (message-from message)
757 (message-action message)
758 (message-body message)
759 (message-in-reply-to message)
760 (message-wants-reply message)
761 (message-replied message)))
763 (define* (write-message message #:optional (port (current-output-port)))
764 "Write out a message to a port for easy reading later.
766 Note that if a sub-value can't be easily written to something
767 Guile's `read' procedure knows how to read, this doesn't do anything
768 to improve that. You'll need a better serializer for that.."
769 (write (serialize-message message) port))
771 (define (serialize-message-pretty message)
772 "Serialize a message in a way that's easy for humans to read."
774 (id ,(message-id message))
775 (to ,(message-to message))
776 (from ,(message-from message))
777 (action ,(message-action message))
778 (body ,(message-body message))
779 (in-reply-to ,(message-in-reply-to message))
780 (wants-reply ,(message-wants-reply message))
781 (replied ,(message-replied message))))
783 (define (pprint-message message)
784 "Pretty print a message."
785 (pretty-print (serialize-message-pretty message)))
787 (define* (read-message #:optional (port (current-input-port)))
788 "Read a message serialized via serialize-message from PORT"
790 ((id to from action body in-reply-to wants-reply replied)
792 id to from action body
793 in-reply-to wants-reply replied))
795 (throw 'message-read-bad-structure
796 "Could not read message from structure"
799 (define (read-message-from-string message-str)
800 "Read message from MESSAGE-STR"
801 (with-input-from-string message-str
803 (read-message (current-input-port)))))