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 (8sync agenda)
28 #:use-module (8sync repl)
29 #:export (;; utilities... ought to go in their own module
31 big-random-number-string
32 simple-message-id-generator
42 address-actor-id address-hive-id
54 ;; There are more methods for the hive, but there's
55 ;; no reason for the outside world to look at them maybe?
57 hive-create-actor hive-create-actor*
61 message-to message-action message-from
62 message-id message-body message-in-reply-to
66 send-message send-message-wait
67 reply-message reply-message-wait
70 hive-bootstrap-message))
74 (make-parameter (random-state-from-platform)))
76 ;; Probably bigger than necessary
77 (define random-number-size (expt 10 50))
79 (define (big-random-number)
80 (random random-number-size (%random-state)))
82 ;; Would be great to get this base64 encoded instead.
83 (define (big-random-number-string)
84 ;; @@: This is slow. Using format here is wasteful.
85 (format #f "~x" (big-random-number)))
87 ;; @@: This is slow. A mere ~275k / second on my (old) machine.
88 ;; The main cost seems to be in number->string.
89 (define (simple-message-id-generator)
90 ;; Prepending this cookie makes message ids unique per hive
91 (let ((prefix (format #f "~x:" (big-random-number)))
94 (set! counter (1+ counter))
95 (string-append prefix (number->string counter)))))
97 (define (require-slot slot-name)
98 "Generate something for #:init-thunk to complain about unfilled slot"
100 (throw 'required-slot
101 (format #f "Slot ~s not filled" slot-name)
106 ;;; Main actor implementation
107 ;;; =========================
109 (define-class <actor> ()
110 ;; An <address> object
111 (id #:init-thunk (require-slot "id")
114 ;; The hive we're connected to.
115 ;; We need this to be able to send messages.
116 (hive #:init-thunk (require-slot "hive")
117 #:init-keyword #:hive
118 #:accessor actor-hive)
119 ;; How we receive and process new messages
120 (message-handler #:init-thunk (require-slot "message-handler")
121 #:allocation #:each-subclass))
123 (define-method (actor-message-handler (actor <actor>))
124 (slot-ref actor 'message-handler))
126 (define-record-type <address>
127 (make-address actor-id hive-id) ; @@: Do we want the trailing -id?
129 (actor-id address-actor-id)
130 (hive-id address-hive-id))
132 ;; (set-record-type-printer!
134 ;; (lambda (record port)
135 ;; (format port "<<address> ~s>" (address->string record))))
137 (define (address->string address)
138 (string-append (address-actor-id address) "@"
139 (address-hive-id address)))
141 (define-method (actor-id-actor (actor <actor>))
142 "Get the actor id component of the actor-id"
143 (address-actor-id (actor-id actor)))
145 (define-method (actor-id-hive (actor <actor>))
146 "Get the hive id component of the actor-id"
147 (address-hive-id (actor-id actor)))
149 (define-method (actor-id-string (actor <actor>))
150 "Render the full actor id as a human-readable string"
151 (address->string (actor-id actor)))
158 (define (simple-dispatcher action-map)
159 (lambda (actor message)
160 (let* ((action (message-action message))
161 (method (assoc-ref action-map action)))
163 (throw 'action-not-found
164 "No appropriate action handler found for actor"
168 #:available-actions (map car action-map)))
169 (method actor message))))
171 (define-syntax %expand-action-item
173 ((_ ((action-name action-args ...) body ...))
174 (cons (quote action-name)
175 (lambda (action-args ...)
177 ((_ (action-name handler))
178 (cons (quote action-name) handler))))
180 (define-syntax make-action-dispatch
182 "Expand a list of action names and actions into an alist
184 You can use this like the following:
185 (make-action-dispatch
187 (lambda (actor message)
188 (display \"I love cookies!\n\")))
190 (lambda (actor message)
191 (display \"Life of the party!\"))))
193 Alternately, if you'd like to skip the lambda, you could use the slightly
194 more compact following syntax:
195 (make-action-dispatch
196 ((cookies actor message)
197 (display \"I love cookies!\n\"))
198 ((party actor message)
199 (display \"Life of the party!\")))"
200 ((make-action-dispatch action-item ...)
202 (list (%expand-action-item action-item) ...)))))
204 (define-syntax-rule (define-simple-actor class (actions ...))
205 (define-class class (<actor>)
207 #:init-value (make-action-dispatch actions ...)
208 #:allocation #:each-subclass)))
213 ;;; Every actor has a hive. The hive is a kind of "meta-actor"
214 ;;; which routes all the rest of the actors in a system.
216 (define-generic hive-handle-failed-forward)
218 (define-class <hive> (<actor>)
219 ;; This gets set to itself immediately after being created
220 (hive #:init-value #f)
221 (actor-registry #:init-thunk make-hash-table
222 #:getter hive-actor-registry)
223 (msg-id-generator #:init-thunk simple-message-id-generator
224 #:getter hive-msg-id-generator)
225 ;; Ambassadors are used (or will be) for inter-hive communication.
226 ;; These are special actors that know how to route messages to other hives.
227 (ambassadors #:init-thunk make-weak-key-hash-table
228 #:getter hive-ambassadors)
229 ;; Waiting coroutines
230 ;; This is a map from cons cell of message-id
231 ;; to a cons cell of (actor-id . coroutine)
232 ;; @@: Should we have a <waiting-coroutine> record type?
233 (waiting-coroutines #:init-thunk make-hash-table
234 #:getter hive-waiting-coroutines)
236 ;; When actors send messages to each other they abort to this prompt
237 ;; to send the message, then carry on their way
238 (prompt #:init-thunk make-prompt-tag
239 #:getter hive-prompt)
242 (make-action-dispatch
243 ;; This is in the case of an ambassador failing to forward a message...
244 ;; it reports it back to the hive
245 (*failed-forward* hive-handle-failed-forward))))
247 (define-method (hive-handle-failed-forward (hive <hive>) message)
248 "Handle an ambassador failing to forward a message"
251 (define* (make-hive #:key hive-id)
252 (let ((hive (make <hive>
255 (big-random-number-string))))))
256 ;; Set the hive's actor reference to itself
257 (set! (actor-hive hive) hive)
260 (define-method (hive-id (hive <hive>))
261 (actor-id-hive hive))
263 (define-method (hive-gen-actor-id (hive <hive>) cookie)
264 (make-address (if cookie
265 (string-append cookie "-" (big-random-number-string))
266 (big-random-number-string))
269 (define-method (hive-gen-message-id (hive <hive>))
270 "Generate a message id using HIVE's message id generator"
271 ((hive-msg-id-generator hive)))
273 (define-method (hive-resolve-local-actor (hive <hive>) actor-address)
274 (hash-ref (hive-actor-registry hive) actor-address))
276 (define-method (hive-resolve-ambassador (hive <hive>) ambassador-address)
277 (hash-ref (hive-ambassadors hive) ambassador-address))
279 (define-method (make-forward-request (hive <hive>) (ambassador <actor>) message)
280 (make-message (hive-gen-message-id hive) (actor-id ambassador)
281 ;; If we make the hive not an actor, we could either switch this
282 ;; to #f or to the original actor...?
283 ;; Maybe some more thinking should be done on what should
284 ;; happen in case of failure to forward? Handling ambassador failures
285 ;; seems like the primary motivation for the hive remaining an actor.
288 `((original . ,message))))
290 (define-method (hive-process-message (hive <hive>) message)
291 "Handle one message, or forward it via an ambassador"
292 (define (process-local-message)
293 (let ((actor (hive-resolve-local-actor hive (message-to message))))
295 (throw 'actor-not-found
296 (format #f "Message ~a from ~a directed to nonexistant actor ~a"
298 (address->string (message-from message))
299 (address->string (message-to message)))
301 (call-with-prompt (hive-prompt hive)
303 (define message-handler (actor-message-handler actor))
304 ;; @@: Should a more general error handling happen here?
305 (message-handler actor message))
307 (lambda (kont actor message)
308 (let ((hive (actor-hive actor)))
309 ;; Register the coroutine
310 (hash-set! (hive-waiting-coroutines hive)
312 (cons (actor-id actor) kont))
313 ;; Send off the message
314 (8sync (hive-process-message hive message)))))))
316 (define (resume-waiting-coroutine)
317 (match (hash-remove! (hive-waiting-coroutines hive)
318 (message-in-reply-to message))
321 (#f (throw 'no-waiting-coroutine
322 "message in-reply-to tries to resume nonexistent coroutine"
325 (define (process-remote-message)
326 ;; Find the ambassador
327 (let* ((remote-hive-id (hive-id (message-to message)))
328 (ambassador (hive-resolve-ambassador remote-hive-id))
329 (message-handler (actor-message-handler ambassador))
330 (forward-request (make-forward-request hive ambassador message)))
331 (message-handler ambassador forward-request)))
333 (let ((to (message-to message)))
334 ;; This seems to be an easy mistake to make, so check that addressing
337 (throw 'missing-addressee
338 "`to' field is missing on message"
340 (if (hive-actor-local? hive to)
341 (if (message-in-reply-to message)
342 (resume-waiting-coroutine)
343 (process-local-message))
344 (process-remote-message))))
346 (define-method (hive-actor-local? (hive <hive>) address)
347 (hash-ref (hive-actor-registry hive) address))
349 (define-method (hive-register-actor! (hive <hive>) (actor <actor>))
350 (hash-set! (hive-actor-registry hive) (actor-id actor) actor))
352 (define-method (%hive-create-actor (hive <hive>) actor-class
354 "Actual method called by hive-create-actor.
356 Since this is a define-method it can't accept fancy define* arguments,
357 so this gets called from the nicer hive-create-actor interface. See
358 that method for documentation."
359 (let* ((actor-id (hive-gen-actor-id hive id-cookie))
360 (actor (apply make actor-class
361 ;; @@: If we switch to a hive-proxy, do it here
365 (hive-register-actor! hive actor)
366 ;; return the actor id
369 (define* (hive-create-actor hive actor-class
373 (%hive-create-actor hive actor-class
376 (define-syntax hive-create-actor*
378 "Create an instance of actor-class attached to this hive.
379 Return the new actor's id.
381 Used internally, and used for bootstrapping a fresh hive.
383 Note that actors should generally not call this method directly.
384 Instead, actors should call create-actor."
385 ((_ args ... (init-args ...))
386 (hive-create-actor args ...
387 #:init (list init-args ...)))))
390 ;; TODO: Give actors this instead of the actual hive reference
391 (define-class <hive-proxy> ()
392 (send-message #:getter proxy-send-message
393 #:init-keyword #:send-message)
394 (create-actor #:getter proxy-create-actor
395 #:init-keyword #:create-actor))
397 ;; Live the hive proxy, but has access to the hive itself...
398 (define-class <debug-hive-proxy> (<hive-proxy>)
399 (hive #:init-keyword #:hive))
407 (define-record-type <message>
408 (make-message-intern id to from action
409 body in-reply-to wants-reply ; do we need hive-proxy?
410 ;; Are these still needed?
411 replied deferred-reply)
416 (action message-action)
418 (in-reply-to message-in-reply-to)
419 (wants-reply message-wants-reply)
421 ;; See XUDD source for these. Not use yet, maybe eventually will be?
422 ;; XUDD uses them for autoreply.
423 ;; Requiring mutation on message objects is clearly not great,
424 ;; but it may be worth it...? Investigate!
425 (replied message-replied set-message-replied!)
426 (deferred-reply deferred-reply set-message-deferred-reply!))
429 (define* (make-message id to from action body
430 #:key in-reply-to wants-reply
431 replied deferred-reply)
432 (make-message-intern id to from action body
433 in-reply-to wants-reply replied
436 ;; Note: the body of messages is currently an alist, but it's created
437 ;; from a keyword based property list (see the following two functions).
438 ;; But, that's an extra conversion step, and maybe totally unnecessary:
439 ;; we already have message-ref, and this could just pull a keyword
440 ;; from a property list.
441 ;; The main ways this might be useful are error checking,
442 ;; serialization across the wire (but even that might require some
443 ;; change), and using existing tooling (though adding new tooling
444 ;; would be negligible in implementation effort.)
446 (define* (message-ref message key #:optional dflt)
447 "Extract KEY from body of MESSAGE.
449 Optionally set default with [DFLT]"
450 (let ((result (assoc key (message-body message))))
451 (if result (cdr result)
455 (define (kwarg-list-to-alist args)
456 (let loop ((remaining args)
459 (((? keyword? key) val rest ...)
461 (cons (cons (keyword->symbol key) val)
464 (_ (throw 'invalid-kwarg-list
465 "Invalid keyword argument list"
469 (define (send-message from-actor to-id action . message-body-args)
470 "Send a message from an actor to another actor"
471 (let* ((hive (actor-hive from-actor))
472 (message (make-message (hive-gen-message-id hive) to-id
473 (actor-id from-actor) action
474 (kwarg-list-to-alist message-body-args))))
475 (8sync (hive-process-message hive message))))
477 (define (send-message-wait from-actor to-id action . message-body-args)
478 "Send a message from an actor to another, but wait until we get a response"
479 (let* ((hive (actor-hive from-actor))
480 (agenda-prompt (hive-prompt (actor-hive from-actor)))
481 (message (make-message (hive-gen-message-id hive) to-id
482 (actor-id from-actor) action
483 (kwarg-list-to-alist message-body-args)
485 (abort-to-prompt agenda-prompt from-actor message)))
487 ;; TODO: Intelligently ~propagate(ish) errors on -wait functions.
488 ;; We might have `send-message-wait-brazen' to allow callers to
489 ;; not have an exception thrown and instead just have a message with
490 ;; the appropriate '*error* message returned.
492 (define (reply-message from-actor original-message
495 (set-message-replied! original-message #t)
496 (let* ((hive (actor-hive from-actor))
497 (new-message (make-message (hive-gen-message-id hive)
498 (message-from original-message)
499 (actor-id from-actor) '*reply*
500 (kwarg-list-to-alist message-body-args)
501 #:in-reply-to (message-id original-message))))
502 (8sync (hive-process-message hive new-message))))
504 (define (reply-message-wait from-actor original-message
506 "Reply to a messsage, but wait until we get a response"
507 (set-message-replied! original-message #t)
508 (let* ((hive (actor-hive from-actor))
509 (agenda-prompt (hive-prompt (actor-hive from-actor)))
510 (new-message (make-message (hive-gen-message-id hive)
511 (message-from original-message)
512 (actor-id from-actor) '*reply*
513 (kwarg-list-to-alist message-body-args)
515 #:in-reply-to (message-id original-message))))
516 (abort-to-prompt agenda-prompt from-actor new-message)))
520 ;;; 8sync bootstrap utilities
521 ;;; =========================
523 (define* (ez-run-hive hive initial-tasks #:key repl-server)
524 "Start up an agenda and run HIVE in it with INITIAL-TASKS.
526 Should we start up a cooperative REPL for live hacking? REPL-SERVER
527 wants to know! You can pass it #t or #f, or if you want to specify a port,
529 (let* ((queue (list->q initial-tasks))
530 (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
533 ;; If repl-server is an integer, we'll use that as the port
534 ((integer? repl-server)
535 (spawn-and-queue-repl-server! agenda repl-server))
537 (spawn-and-queue-repl-server! agenda)))
538 (start-agenda agenda)))
540 (define (hive-bootstrap-message hive to-id action . message-body-args)
542 (apply send-message hive to-id action message-body-args)))