8sync/systems/actors.scm

   1 ;;; 8sync --- Asynchronous programming for Guile
   2 ;;; Copyright (C) 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; This file is part of 8sync.
   5 ;;;
   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.
  10 ;;;
  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.
  15 ;;;
  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/>.
  18
  19 ;; XUDD inspired actor system
  20
  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
  32             big-random-number
  33             big-random-number-string
  34             simple-message-id-generator
  35
  36             <actor>
  37             actor-id
  38             actor-message-handler
  39
  40             %current-actor
  41
  42             ;;; Commenting out the <address> type for now;
  43             ;;; it may be back when we have better serializers
  44             ;; <address>
  45             make-address address?
  46             address-actor-id address-hive-id
  47
  48             address->string
  49             actor-id-actor
  50             actor-id-hive
  51             actor-id-string
  52
  53             simple-dispatcher build-actions make-action-dispatch
  54             define-simple-actor
  55
  56             mhandlers
  57
  58             <hive>
  59             make-hive
  60             ;; There are more methods for the hive, but there's
  61             ;; no reason for the outside world to look at them maybe?
  62             hive-id
  63             hive-create-actor hive-create-actor*
  64
  65             create-actor create-actor*
  66             self-destruct
  67
  68             <message>
  69             make-message message?
  70             message-to message-action message-from
  71             message-id message-body message-in-reply-to
  72             message-wants-reply
  73
  74             message-auto-reply?
  75
  76             <- <-wait <-reply <-reply-wait
  77
  78             call-with-message msg-receive msg-val
  79
  80             ez-run-hive
  81             bootstrap-message
  82
  83             serialize-message write-message
  84             serialize-message-pretty pprint-message
  85             read-message read-message-from-string))
  86
  87 ;; For ids
  88 (define %random-state
  89   (make-parameter (random-state-from-platform)))
  90
  91 ;; Same size as a uuid4 I think...
  92 (define random-number-size (expt 2 128))
  93
  94 (define (big-random-number)
  95   (random random-number-size (%random-state)))
  96
  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)))
 101
 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)))
 107         (counter 0))
 108     (lambda ()
 109       (set! counter (1+ counter))
 110       (string-append prefix (number->string counter)))))
 111
 112
 113 \f
 114 ;;; Messages
 115 ;;; ========
 116
 117
 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.
 122
 123 (define-record-type <message>
 124   (make-message-intern id to from action
 125                        body in-reply-to wants-reply
 126                        replied)
 127   message?
 128   (id message-id)
 129   (to message-to)
 130   (from message-from)
 131   (action message-action)
 132   (body message-body)
 133   (in-reply-to message-in-reply-to)
 134   (wants-reply message-wants-reply)
 135   (replied message-replied set-message-replied!))
 136
 137
 138 (define* (make-message id to from action body
 139                        #:key in-reply-to wants-reply
 140                        replied)
 141   (make-message-intern id to from action body
 142                        in-reply-to wants-reply replied))
 143
 144 (define (message-auto-reply? message)
 145   (eq? (message-action message) '*auto-reply*))
 146
 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))))
 151
 152
 153 (define (kwarg-list-to-alist args)
 154   (let loop ((remaining args)
 155              (result '()))
 156     (match remaining
 157       (((? keyword? key) val rest ...)
 158        (loop rest
 159              (cons (cons (keyword->symbol key) val)
 160                    result)))
 161       (() result)
 162       (_ (throw 'invalid-kwarg-list
 163                 "Invalid keyword argument list"
 164                 args)))))
 165
 166
 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 )
 169
 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
 175                                 message-body-args)))
 176     (8sync (hive-process-message hive message))))
 177
 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
 184                                 message-body-args
 185                                 #:wants-reply #t)))
 186     (abort-to-prompt abort-to from-actor message)))
 187
 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.
 192
 193 (define (<-reply from-actor original-message . message-body-args)
 194   "Reply to a message"
 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*
 200                                     message-body-args
 201                                     #:in-reply-to (message-id original-message))))
 202     (8sync (hive-process-message hive new-message))))
 203
 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*
 211                                     '()
 212                                     #:in-reply-to (message-id original-message))))
 213     (8sync (hive-process-message hive new-message))))
 214
 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*
 223                                     message-body-args
 224                                     #:wants-reply #t
 225                                     #:in-reply-to (message-id original-message))))
 226     (abort-to-prompt abort-to from-actor new-message)))
 227
 228
 229 \f
 230 ;;; Main actor implementation
 231 ;;; =========================
 232
 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)
 237                 (define actions
 238                   (or (and (class-slot-definition this-class 'actions)
 239                            (class-slot-ref this-class 'actions))
 240                       '()))
 241                 (for-each (match-lambda
 242                             ((action-name . method)
 243                              (when (eq? action-name action)
 244                                (return method))))
 245                           actions))
 246               (class-precedence-list (class-of actor)))
 247     (throw 'action-not-found
 248            "No appropriate action handler found for actor"
 249            #:action action
 250            #:actor actor
 251            #:message message))
 252   (define method
 253     (call/ec find-message-handler))
 254   (apply method actor message (message-body message)))
 255
 256 (define-class <actor> ()
 257   ;; An address object
 258   (id #:init-keyword #:id
 259       #:getter actor-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)
 270
 271   ;; This is the default, "simple" way to inherit and process messages.
 272   (actions #:init-value '()
 273            #:allocation #:each-subclass))
 274
 275 (define-method (actor-message-handler (actor <actor>))
 276   (slot-ref actor 'message-handler))
 277
 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.
 281
 282 ;; (define-record-type <address>
 283 ;;   (make-address actor-id hive-id)  ; @@: Do we want the trailing -id?
 284 ;;   address?
 285 ;;   (actor-id address-actor-id)
 286 ;;   (hive-id address-hive-id))
 287 ;;
 288 ;; (set-record-type-printer!
 289 ;;  <address>
 290 ;;  (lambda (record port)
 291 ;;    (format port "<address: ~s@~s>"
 292 ;;            (address-actor-id record) (address-hive-id record))))
 293 ;;
 294
 295 (define (make-address actor-id hive-id)
 296   (cons actor-id hive-id))
 297
 298 (define (address-actor-id address)
 299   (car address))
 300
 301 (define (address-hive-id address)
 302   (cdr address))
 303
 304 (define (address->string address)
 305   (string-append (address-actor-id address) "@"
 306                  (address-hive-id address)))
 307
 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)))
 311
 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)))
 315
 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)))
 319
 320 (define %current-actor
 321   (make-parameter #f))
 322
 323
 324 \f
 325 ;;; Actor utilities
 326 ;;; ===============
 327
 328 ;;;;;;;;;;; Deprecated abstractions start here ;;;;;;;;;;;
 329
 330 (define (simple-dispatcher action-map)
 331   (lambda (actor message)
 332     (let* ((action (message-action message))
 333            (method (assoc-ref action-map action)))
 334       (if (not method)
 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"
 339                  #:action action
 340                  #:actor actor
 341                  #:message message
 342                  #:available-actions (map car action-map)))
 343       (apply method actor message (message-body message)))))
 344
 345 (define-syntax %expand-action-item
 346   (syntax-rules ()
 347     ((_ (action-name handler))
 348      (cons (quote action-name) handler))))
 349
 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).
 354
 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) ...))
 358
 359 (define-syntax make-action-dispatch
 360   (syntax-rules ()
 361     "Expand a list of action names and actions into an alist
 362
 363 You can use this like the following:
 364   (make-action-dispatch
 365    (cookies
 366     (lambda (actor message)
 367       (display \"I love cookies!\n\")))
 368    (party
 369     (lambda (actor message)
 370       (display \"Life of the party!\"))))
 371
 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 ...)))))
 381
 382 ;;;;;;;;;;; Deprecated abstractions end here ;;;;;;;;;;;
 383
 384
 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."
 389   (list
 390    (cons (quote symbol)
 391          (wrap-apply method)) ...))
 392
 393 (define-syntax-rule (define-simple-actor class action ...)
 394   (define-class class (<actor>)
 395     (actions #:init-value (mhandlers action ...)
 396              #:allocation #:each-subclass)))
 397
 398 \f
 399 ;;; The Hive
 400 ;;; ========
 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.
 403
 404 (define-generic hive-handle-failed-forward)
 405
 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)
 422   ;; Message prompt
 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)
 427   (message-handler
 428    #:init-value
 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))))
 433
 434 (define-method (hive-handle-failed-forward (hive <hive>) message)
 435   "Handle an ambassador failing to forward a message"
 436   'TODO)
 437
 438 (define* (make-hive #:key hive-id)
 439   (let ((hive (make <hive>
 440                 #:id (make-address
 441                       "hive" (or hive-id
 442                                  (big-random-number-string))))))
 443     ;; Set the hive's actor reference to itself
 444     (set! (actor-hive hive) hive)
 445     hive))
 446
 447 (define-method (hive-id (hive <hive>))
 448   (actor-id-hive hive))
 449
 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))
 454                 (hive-id hive)))
 455
 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)))
 459
 460 (define-method (hive-resolve-local-actor (hive <hive>) actor-address)
 461   (hash-ref (hive-actor-registry hive) actor-address))
 462
 463 (define-method (hive-resolve-ambassador (hive <hive>) ambassador-address)
 464   (hash-ref (hive-ambassadors hive) ambassador-address))
 465
 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.
 473                 (actor-id hive)
 474                 '*forward*
 475                 `((original . ,message))))
 476
 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*
 494                                     new-message-body
 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))))
 500
 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)))
 507
 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))))
 511       (if (not actor)
 512           (throw 'actor-not-found
 513                  (format #f "Message ~a from ~a directed to nonexistant actor ~a"
 514                          (message-id message)
 515                          (address->string (message-from message))
 516                          (address->string (message-to message)))
 517                  message))
 518       actor))
 519
 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
 529       (catch #t
 530         thunk
 531         ;; In the actor model, we don't totally crash on errors.
 532         (lambda _ #f)
 533         ;; If an error happens, we raise it
 534         (lambda (key . args)
 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
 540               ;; situation.
 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)
 549       call-catching-errors
 550       (lambda (kont actor message)
 551         ;; Register the coroutine
 552         (hash-set! (hive-waiting-coroutines hive)
 553                    (message-id message)
 554                    (cons (actor-id actor) kont))
 555         ;; Send off the message
 556         (8sync (hive-process-message hive message)))))
 557
 558   (define (process-local-message)
 559     (let ((actor (resolve-actor-to)))
 560       (call-catching-coroutine
 561        (lambda ()
 562          (define message-handler (actor-message-handler actor))
 563          ;; @@: Should a more general error handling happen here?
 564          (parameterize ((%current-actor actor))
 565            (let ((result
 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?
 571              result))))))
 572
 573   (define (resume-waiting-coroutine)
 574     (cond
 575      ((or (eq? (message-action message) '*reply*)
 576           (eq? (message-action message) '*auto-reply*))
 577       (call-catching-coroutine
 578        (lambda ()
 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)
 583                              resume-actor-id))
 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
 588                        #:message message))
 589             (let (;; @@: How should we resolve resuming coroutines to actors who are
 590                   ;;   now gone?
 591                   (actor (resolve-actor-to))
 592                   (result (kont message)))
 593               (maybe-autoreply actor)
 594               result))
 595            (#f (throw 'no-waiting-coroutine
 596                       "message in-reply-to tries to resume nonexistent coroutine"
 597                       message))))))
 598      ;; Yikes, we must have gotten an error or something back
 599      (else
 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))
 606       (let ((explaination
 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
 611                explaination
 612                #:message message)))))
 613
 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)))
 621
 622   (let ((to (message-to message)))
 623     ;; This seems to be an easy mistake to make, so check that addressing
 624     ;; is correct here
 625     (if (not to)
 626         (throw 'missing-addressee
 627                "`to' field is missing on message"
 628                #:message 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))))
 634
 635 (define-method (hive-actor-local? (hive <hive>) address)
 636   (equal? (hive-id hive) (address-hive-id address)))
 637
 638 (define-method (hive-register-actor! (hive <hive>) (actor <actor>))
 639   (hash-set! (hive-actor-registry hive) (actor-id actor) actor))
 640
 641 (define-method (%hive-create-actor (hive <hive>) actor-class
 642                                    init id-cookie)
 643   "Actual method called by hive-create-actor.
 644
 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
 650                        #:hive hive
 651                        #:id actor-id
 652                        init)))
 653     (hive-register-actor! hive actor)
 654     ;; return the actor id
 655     actor-id))
 656
 657 (define* (hive-create-actor hive actor-class #:rest init)
 658   (%hive-create-actor hive actor-class
 659                       init #f))
 660
 661 (define* (hive-create-actor* hive actor-class id-cookie #:rest init)
 662   (%hive-create-actor hive actor-class
 663                       init id-cookie))
 664
 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)))
 669
 670 ;; (msg-receive (<- bar baz)
 671 ;;     (baz)
 672 ;;   basil)
 673
 674 ;; Emacs: (put 'msg-receive 'scheme-indent-function 2)
 675
 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
 681                      (lambda* arglist
 682                        body ...)))
 683
 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)))
 690
 691 \f
 692 ;;; Various API methods for actors to interact with the system
 693 ;;; ==========================================================
 694
 695 ;; TODO: move send-message and friends here...?
 696
 697 (define* (create-actor from-actor actor-class #:rest init)
 698   "Create an instance of actor-class.  Return the new actor's id.
 699
 700 This is the method actors should call directly (unless they want
 701 to supply an id-cookie, in which case they should use
 702 create-actor*)."
 703   (%hive-create-actor (actor-hive from-actor) actor-class
 704                       init #f))
 705
 706
 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.
 709
 710 Like create-actor, but permits supplying an id-cookie."
 711   (%hive-create-actor (actor-hive from-actor) actor-class
 712                       init id-cookie))
 713
 714
 715 (define (self-destruct actor)
 716   "Remove an actor from the hive."
 717   (hash-remove! (hive-actor-registry (actor-hive actor))
 718                 (actor-id actor)))
 719
 720
 721 \f
 722 ;;; 8sync bootstrap utilities
 723 ;;; =========================
 724
 725 (define* (ez-run-hive hive initial-tasks #:key repl-server)
 726   "Start up an agenda and run HIVE in it with INITIAL-TASKS.
 727
 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,
 730 an integer."
 731   (let* ((queue (list->q initial-tasks))
 732          (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
 733                               #:queue queue)))
 734     (cond
 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))
 738      (repl-server
 739       (spawn-and-queue-repl-server! agenda)))
 740     (start-agenda agenda)))
 741
 742 (define (bootstrap-message hive to-id action . message-body-args)
 743   (wrap
 744    (apply <- hive to-id action message-body-args)))
 745
 746
 747 \f
 748 ;;; Basic readers / writers
 749 ;;; =======================
 750
 751 (define (serialize-message message)
 752   "Serialize a message for read/write"
 753   (list
 754    (message-id message)
 755    (message-to message)
 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)))
 762
 763 (define* (write-message message #:optional (port (current-output-port)))
 764   "Write out a message to a port for easy reading later.
 765
 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))
 770
 771 (define (serialize-message-pretty message)
 772   "Serialize a message in a way that's easy for humans to read."
 773   `(*message*
 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))))
 782
 783 (define (pprint-message message)
 784   "Pretty print a message."
 785   (pretty-print (serialize-message-pretty message)))
 786
 787 (define* (read-message #:optional (port (current-input-port)))
 788   "Read a message serialized via serialize-message from PORT"
 789   (match (read port)
 790     ((id to from action body in-reply-to wants-reply replied)
 791      (make-message-intern
 792       id to from action body
 793       in-reply-to wants-reply replied))
 794     (anything-else
 795      (throw 'message-read-bad-structure
 796             "Could not read message from structure"
 797             anything-else))))
 798
 799 (define (read-message-from-string message-str)
 800   "Read message from MESSAGE-STR"
 801   (with-input-from-string message-str
 802     (lambda ()
 803       (read-message (current-input-port)))))