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 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
  31             big-random-number
  32             big-random-number-string
  33             simple-message-id-generator
  34
  35             <actor>
  36             actor-id
  37             actor-message-handler
  38
  39             ;;; Commenting out the <address> type for now;
  40             ;;; it may be back when we have better serializers
  41             ;; <address>
  42             make-address address?
  43             address-actor-id address-hive-id
  44
  45             address->string
  46             actor-id-actor
  47             actor-id-hive
  48             actor-id-string
  49
  50             mlambda define-mhandler
  51             simple-dispatcher build-actions make-action-dispatch
  52             define-simple-actor
  53
  54             <hive>
  55             make-hive
  56             ;; There are more methods for the hive, but there's
  57             ;; no reason for the outside world to look at them maybe?
  58             hive-id
  59             hive-create-actor hive-create-actor*
  60
  61             create-actor create-actor*
  62             self-destruct
  63
  64             <message>
  65             make-message message?
  66             message-to message-action message-from
  67             message-id message-body message-in-reply-to
  68             message-wants-reply
  69             message-ref
  70
  71             send-message send-message-wait
  72             reply-message reply-message-wait
  73
  74             <- <-wait <-reply <-reply-wait
  75
  76             ez-run-hive
  77             bootstrap-message
  78
  79             serialize-message write-message
  80             serialize-message-pretty pprint-message
  81             read-message read-message-from-string))
  82
  83 ;; For ids
  84 (define %random-state
  85   (make-parameter (random-state-from-platform)))
  86
  87 ;; Same size as a uuid4 I think...
  88 (define random-number-size (expt 2 128))
  89
  90 (define (big-random-number)
  91   (random random-number-size (%random-state)))
  92
  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)))
  97
  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)))
 103         (counter 0))
 104     (lambda ()
 105       (set! counter (1+ counter))
 106       (string-append prefix (number->string counter)))))
 107
 108
 109 \f
 110 ;;; Messages
 111 ;;; ========
 112
 113
 114 (define-record-type <message>
 115   (make-message-intern id to from action
 116                        body in-reply-to wants-reply
 117                        replied
 118                        ;; @@: Not used yet.
 119                        ;; Will we ever find a real use case?
 120                        deferred-reply)
 121   message?
 122   (id message-id)
 123   (to message-to)
 124   (from message-from)
 125   (action message-action)
 126   (body message-body)
 127   (in-reply-to message-in-reply-to)
 128   (wants-reply message-wants-reply)
 129
 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!))
 136
 137
 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
 143                        deferred-reply))
 144
 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.)
 154
 155 ;; This cons cell is immutable and unique (for eq? tests)
 156 (define %nothing-provided (cons 'nothing 'provided))
 157
 158 (define* (message-ref message key #:optional (dflt %nothing-provided))
 159   "Extract KEY from body of MESSAGE.
 160
 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"
 168                    #:key key
 169                    #:message message)
 170             dflt))))
 171
 172
 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)))))
 178
 179
 180 (define (kwarg-list-to-alist args)
 181   (let loop ((remaining args)
 182              (result '()))
 183     (match remaining
 184       (((? keyword? key) val rest ...)
 185        (loop rest
 186              (cons (cons (keyword->symbol key) val)
 187                    result)))
 188       (() result)
 189       (_ (throw 'invalid-kwarg-list
 190                 "Invalid keyword argument list"
 191                 args)))))
 192
 193
 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-nowait (hive-process-message hive message))))
 201
 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)
 209                                 #:wants-reply #t)))
 210     (abort-to-prompt abort-to from-actor message)))
 211
 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.
 216
 217 (define (reply-message from-actor original-message
 218                        . message-body-args)
 219   "Reply to a 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-nowait (hive-process-message hive new-message))))
 228
 229 (define (reply-message-wait from-actor original-message
 230                             . message-body-args)
 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)
 239                                     #:wants-reply #t
 240                                     #:in-reply-to (message-id original-message))))
 241     (abort-to-prompt abort-to from-actor new-message)))
 242
 243
 244 ;;; Aliases!
 245 ;;; See: http://mumble.net/~jar/articles/oo-moon-weinreb.html
 246 ;;;   (also worth seeing: http://mumble.net/~jar/articles/oo.html )
 247
 248 (define <- send-message)
 249 (define <-wait send-message-wait)
 250 (define <-reply reply-message)
 251 (define <-reply-wait reply-message-wait)
 252
 253
 254 \f
 255 ;;; Main actor implementation
 256 ;;; =========================
 257
 258 (define-class <actor> ()
 259   ;; An address object
 260   (id #:init-keyword #:id
 261       #:getter actor-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))
 268
 269 (define-method (actor-message-handler (actor <actor>))
 270   (slot-ref actor 'message-handler))
 271
 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.
 275
 276 ;; (define-record-type <address>
 277 ;;   (make-address actor-id hive-id)  ; @@: Do we want the trailing -id?
 278 ;;   address?
 279 ;;   (actor-id address-actor-id)
 280 ;;   (hive-id address-hive-id))
 281 ;;
 282 ;; (set-record-type-printer!
 283 ;;  <address>
 284 ;;  (lambda (record port)
 285 ;;    (format port "<address: ~s@~s>"
 286 ;;            (address-actor-id record) (address-hive-id record))))
 287 ;;
 288
 289 (define (make-address actor-id hive-id)
 290   (cons actor-id hive-id))
 291
 292 (define (address-actor-id address)
 293   (car address))
 294
 295 (define (address-hive-id address)
 296   (cdr address))
 297
 298 (define (address->string address)
 299   (string-append (address-actor-id address) "@"
 300                  (address-hive-id address)))
 301
 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)))
 305
 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)))
 309
 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)))
 313
 314
 315 \f
 316 ;;; Actor utilities
 317 ;;; ===============
 318
 319
 320 (define-syntax-rule (with-message-args (message message-arg ...)
 321                                        body body* ...)
 322   (let ((message-arg (message-ref message (quote message-arg))) ...)
 323     body body* ...))
 324
 325 (define-syntax mlambda
 326   (lambda (x)
 327     "A lambda for building message handlers.
 328
 329 Use it like:
 330   (mlambda (actor message foo)
 331     ...)
 332
 333 Which is like doing manually:
 334   (lambda (actor message)
 335     (let ((foo (message-ref message foo)))
 336       ...))"
 337     (syntax-case x ()
 338       ((_ (actor message message-arg ...)
 339           docstring
 340           body ...)
 341        (string? (syntax->datum #'docstring))
 342        #'(lambda (actor message)
 343            docstring
 344            (with-message-args (message message-arg ...) body ...)))
 345       ((_ (actor message message-arg ...)
 346           body body* ...)
 347        #'(lambda (actor message)
 348            (with-message-args (message message-arg ...) body body* ...))))))
 349
 350 (define-syntax-rule (define-mhandler (name actor message message-arg ...)
 351                       body ...)
 352   (define name
 353     (mlambda (actor message message-arg ...)
 354              body ...)))
 355
 356 (define (simple-dispatcher action-map)
 357   (lambda (actor message)
 358     (let* ((action (message-action message))
 359            (method (assoc-ref action-map action)))
 360       (if (not method)
 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"
 365                  #:action action
 366                  #:actor actor
 367                  #:message message
 368                  #:available-actions (map car action-map)))
 369       (method actor message))))
 370
 371 (define-syntax %expand-action-item
 372   (syntax-rules ()
 373     ((_ ((action-name action-args ...) body ...))
 374      (cons (quote action-name)
 375            (mlambda (action-args ...)
 376              body ...)))
 377     ((_ (action-name handler))
 378      (cons (quote action-name) handler))))
 379
 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).
 384
 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) ...))
 388
 389 (define-syntax make-action-dispatch
 390   (syntax-rules ()
 391     "Expand a list of action names and actions into an alist
 392
 393 You can use this like the following:
 394   (make-action-dispatch
 395    (cookies
 396     (lambda (actor message)
 397       (display \"I love cookies!\n\")))
 398    (party
 399     (lambda (actor message)
 400       (display \"Life of the party!\"))))
 401
 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 ...)))))
 411
 412 (define-syntax-rule (define-simple-actor class actions ...)
 413   (define-class class (<actor>)
 414     (message-handler
 415      #:init-value (make-action-dispatch actions ...)
 416      #:allocation #:each-subclass)))
 417
 418 \f
 419 ;;; The Hive
 420 ;;; ========
 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.
 423
 424 (define-generic hive-handle-failed-forward)
 425
 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)
 442   ;; Message prompt
 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)
 447   (message-handler
 448    #:init-value
 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))))
 453
 454 (define-method (hive-handle-failed-forward (hive <hive>) message)
 455   "Handle an ambassador failing to forward a message"
 456   'TODO)
 457
 458 (define* (make-hive #:key hive-id)
 459   (let ((hive (make <hive>
 460                 #:id (make-address
 461                       "hive" (or hive-id
 462                                  (big-random-number-string))))))
 463     ;; Set the hive's actor reference to itself
 464     (set! (actor-hive hive) hive)
 465     hive))
 466
 467 (define-method (hive-id (hive <hive>))
 468   (actor-id-hive hive))
 469
 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))
 474                 (hive-id hive)))
 475
 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)))
 479
 480 (define-method (hive-resolve-local-actor (hive <hive>) actor-address)
 481   (hash-ref (hive-actor-registry hive) actor-address))
 482
 483 (define-method (hive-resolve-ambassador (hive <hive>) ambassador-address)
 484   (hash-ref (hive-ambassadors hive) ambassador-address))
 485
 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.
 493                 (actor-id hive)
 494                 '*forward*
 495                 `((original . ,message))))
 496
 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*
 514                                     new-message-body
 515                                     #:in-reply-to (message-id original-message))))
 516     (8sync-nowait (hive-process-message hive new-message))))
 517
 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
 525                        #:*auto-reply* #t)))
 526
 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))))
 530       (if (not actor)
 531           (throw 'actor-not-found
 532                  (format #f "Message ~a from ~a directed to nonexistant actor ~a"
 533                          (message-id message)
 534                          (address->string (message-from message))
 535                          (address->string (message-to message)))
 536                  message))
 537       actor))
 538
 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
 547       (catch #t
 548         thunk
 549         ;; In the actor model, we don't totally crash on errors.
 550         (lambda _ #f)
 551         ;; If an error happens, we raise it
 552         (lambda (key . args)
 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)
 560       call-catching-errors
 561       (lambda (kont actor message)
 562         ;; Register the coroutine
 563         (hash-set! (hive-waiting-coroutines hive)
 564                    (message-id message)
 565                    (cons (actor-id actor) kont))
 566         ;; Send off the message
 567         (8sync (hive-process-message hive message)))))
 568
 569   (define (process-local-message)
 570     (let ((actor (resolve-actor-to)))
 571       (call-catching-coroutine
 572        (lambda ()
 573          (define message-handler (actor-message-handler actor))
 574          ;; @@: Should a more general error handling happen here?
 575          (let ((result
 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?
 581            result)))))
 582
 583   (define (resume-waiting-coroutine)
 584     (cond
 585      ((eq? (message-action message) '*reply*)
 586       (call-catching-coroutine
 587        (lambda ()
 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)
 592                              resume-actor-id))
 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
 597                        #:message message))
 598             (let (;; @@: How should we resolve resuming coroutines to actors who are
 599                   ;;   now gone?
 600                   (actor (resolve-actor-to))
 601                   (result (kont message)))
 602               (maybe-autoreply actor)
 603               result))
 604            (#f (throw 'no-waiting-coroutine
 605                       "message in-reply-to tries to resume nonexistent coroutine"
 606                       message))))))
 607      ;; Yikes, we must have gotten an error or something back
 608      (else
 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))
 615       (let ((explaination
 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
 620                explaination
 621                #:message message)))))
 622
 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)))
 630
 631   (let ((to (message-to message)))
 632     ;; This seems to be an easy mistake to make, so check that addressing
 633     ;; is correct here
 634     (if (not to)
 635         (throw 'missing-addressee
 636                "`to' field is missing on message"
 637                #:message 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))))
 643
 644 (define-method (hive-actor-local? (hive <hive>) address)
 645   (equal? (hive-id hive) (address-hive-id address)))
 646
 647 (define-method (hive-register-actor! (hive <hive>) (actor <actor>))
 648   (hash-set! (hive-actor-registry hive) (actor-id actor) actor))
 649
 650 (define-method (%hive-create-actor (hive <hive>) actor-class
 651                                    init id-cookie)
 652   "Actual method called by hive-create-actor.
 653
 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
 659                        #:hive hive
 660                        #:id actor-id
 661                        init)))
 662     (hive-register-actor! hive actor)
 663     ;; return the actor id
 664     actor-id))
 665
 666 (define* (hive-create-actor hive actor-class #:rest init)
 667   (%hive-create-actor hive actor-class
 668                       init #f))
 669
 670 (define* (hive-create-actor* hive actor-class id-cookie #:rest init)
 671   (%hive-create-actor hive actor-class
 672                       init id-cookie))
 673
 674
 675 \f
 676 ;;; Various API methods for actors to interact with the system
 677 ;;; ==========================================================
 678
 679 ;; TODO: move send-message and friends here...?
 680
 681 (define* (create-actor from-actor actor-class #:rest init)
 682   "Create an instance of actor-class.  Return the new actor's id.
 683
 684 This is the method actors should call directly (unless they want
 685 to supply an id-cookie, in which case they should use
 686 create-actor*)."
 687   (8sync (%hive-create-actor (actor-hive from-actor) actor-class
 688                              init #f)))
 689
 690
 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.
 693
 694 Like create-actor, but permits supplying an id-cookie."
 695   (8sync (%hive-create-actor (actor-hive from-actor) actor-class
 696                              init id-cookie)))
 697
 698
 699 (define (self-destruct actor)
 700   "Remove an actor from the hive."
 701   (hash-remove! (hive-actor-registry (actor-hive actor))
 702                 (actor-id actor)))
 703
 704
 705 \f
 706 ;;; 8sync bootstrap utilities
 707 ;;; =========================
 708
 709 (define* (ez-run-hive hive initial-tasks #:key repl-server)
 710   "Start up an agenda and run HIVE in it with INITIAL-TASKS.
 711
 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,
 714 an integer."
 715   (let* ((queue (list->q initial-tasks))
 716          (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
 717                               #:queue queue)))
 718     (cond
 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))
 722      (repl-server
 723       (spawn-and-queue-repl-server! agenda)))
 724     (start-agenda agenda)))
 725
 726 (define (bootstrap-message hive to-id action . message-body-args)
 727   (wrap
 728    (apply send-message hive to-id action message-body-args)))
 729
 730
 731 \f
 732 ;;; Basic readers / writers
 733 ;;; =======================
 734
 735 (define (serialize-message message)
 736   "Serialize a message for read/write"
 737   (list
 738    (message-id message)
 739    (message-to message)
 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)))
 747
 748 (define* (write-message message #:optional (port (current-output-port)))
 749   "Write out a message to a port for easy reading later.
 750
 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))
 755
 756 (define (serialize-message-pretty message)
 757   "Serialize a message in a way that's easy for humans to read."
 758   `(*message*
 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))))
 768
 769 (define (pprint-message message)
 770   "Pretty print a message."
 771   (pretty-print (serialize-message-pretty message)))
 772
 773 (define* (read-message #:optional (port (current-input-port)))
 774   "Read a message serialized via serialize-message from PORT"
 775   (match (read port)
 776     ((id to from action body in-reply-to wants-reply replied deferred-reply)
 777      (make-message-intern
 778       id to from action body
 779       in-reply-to wants-reply replied deferred-reply))
 780     (anything-else
 781      (throw 'message-read-bad-structure
 782             "Could not read message from structure"
 783             anything-else))))
 784
 785 (define (read-message-from-string message-str)
 786   "Read message from MESSAGE-STR"
 787   (with-input-from-string message-str
 788     (lambda ()
 789       (read-message (current-input-port)))))