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             simple-dispatcher build-actions make-action-dispatch
  51             define-simple-actor
  52
  53             <hive>
  54             make-hive
  55             ;; There are more methods for the hive, but there's
  56             ;; no reason for the outside world to look at them maybe?
  57             hive-id
  58             hive-create-actor hive-create-actor*
  59
  60             create-actor create-actor*
  61             self-destruct
  62
  63             <message>
  64             make-message message?
  65             message-to message-action message-from
  66             message-id message-body message-in-reply-to
  67             message-wants-reply
  68
  69             message-auto-reply?
  70
  71             <- <-wait <-reply <-reply-wait
  72
  73             call-with-message msg-receive =>
  74
  75             ez-run-hive
  76             bootstrap-message
  77
  78             serialize-message write-message
  79             serialize-message-pretty pprint-message
  80             read-message read-message-from-string))
  81
  82 ;; For ids
  83 (define %random-state
  84   (make-parameter (random-state-from-platform)))
  85
  86 ;; Same size as a uuid4 I think...
  87 (define random-number-size (expt 2 128))
  88
  89 (define (big-random-number)
  90   (random random-number-size (%random-state)))
  91
  92 ;; Would be great to get this base64 encoded instead.
  93 (define (big-random-number-string)
  94   ;; @@: This is slow.  Using format here is wasteful.
  95   (format #f "~x" (big-random-number)))
  96
  97 ;; @@: This is slow.  A mere ~275k / second on my (old) machine.
  98 ;;   The main cost seems to be in number->string.
  99 (define (simple-message-id-generator)
 100   ;; Prepending this cookie makes message ids unique per hive
 101   (let ((prefix (format #f "~x:" (big-random-number)))
 102         (counter 0))
 103     (lambda ()
 104       (set! counter (1+ counter))
 105       (string-append prefix (number->string counter)))))
 106
 107
 108 \f
 109 ;;; Messages
 110 ;;; ========
 111
 112
 113 (define-record-type <message>
 114   (make-message-intern id to from action
 115                        body in-reply-to wants-reply
 116                        replied)
 117   message?
 118   (id message-id)
 119   (to message-to)
 120   (from message-from)
 121   (action message-action)
 122   (body message-body)
 123   (in-reply-to message-in-reply-to)
 124   (wants-reply message-wants-reply)
 125   (replied message-replied set-message-replied!))
 126
 127
 128 (define* (make-message id to from action body
 129                        #:key in-reply-to wants-reply
 130                        replied)
 131   (make-message-intern id to from action body
 132                        in-reply-to wants-reply replied))
 133
 134 (define (message-auto-reply? message)
 135   (eq? (message-action message) '*auto-reply*))
 136
 137 (define (message-needs-reply? message)
 138   "See if this message needs a reply still"
 139   (and (message-wants-reply message)
 140        (not (message-replied message))))
 141
 142
 143 (define (kwarg-list-to-alist args)
 144   (let loop ((remaining args)
 145              (result '()))
 146     (match remaining
 147       (((? keyword? key) val rest ...)
 148        (loop rest
 149              (cons (cons (keyword->symbol key) val)
 150                    result)))
 151       (() result)
 152       (_ (throw 'invalid-kwarg-list
 153                 "Invalid keyword argument list"
 154                 args)))))
 155
 156
 157 ;;; See: https://web.archive.org/web/20081223021934/http://mumble.net/~jar/articles/oo-moon-weinreb.html
 158 ;;;   (also worth seeing: http://mumble.net/~jar/articles/oo.html )
 159
 160 (define (<- from-actor to-id action . message-body-args)
 161   "Send a message from an actor to another actor"
 162   (let* ((hive (actor-hive from-actor))
 163          (message (make-message (hive-gen-message-id hive) to-id
 164                                 (actor-id from-actor) action
 165                                 message-body-args)))
 166     (8sync (hive-process-message hive message))))
 167
 168 (define (<-wait from-actor to-id action . message-body-args)
 169   "Send a message from an actor to another, but wait until we get a response"
 170   (let* ((hive (actor-hive from-actor))
 171          (abort-to (hive-prompt (actor-hive from-actor)))
 172          (message (make-message (hive-gen-message-id hive) to-id
 173                                 (actor-id from-actor) action
 174                                 message-body-args
 175                                 #:wants-reply #t)))
 176     (abort-to-prompt abort-to from-actor message)))
 177
 178 ;; TODO: Intelligently ~propagate(ish) errors on -wait functions.
 179 ;;   We might have `send-message-wait-brazen' to allow callers to
 180 ;;   not have an exception thrown and instead just have a message with
 181 ;;   the appropriate '*error* message returned.
 182
 183 (define (<-reply from-actor original-message . message-body-args)
 184   "Reply to a message"
 185   (set-message-replied! original-message #t)
 186   (let* ((hive (actor-hive from-actor))
 187          (new-message (make-message (hive-gen-message-id hive)
 188                                     (message-from original-message)
 189                                     (actor-id from-actor) '*reply*
 190                                     message-body-args
 191                                     #:in-reply-to (message-id original-message))))
 192     (8sync (hive-process-message hive new-message))))
 193
 194 (define (<-auto-reply from-actor original-message)
 195   "Auto-reply to a message.  Internal use only!"
 196   (set-message-replied! original-message #t)
 197   (let* ((hive (actor-hive from-actor))
 198          (new-message (make-message (hive-gen-message-id hive)
 199                                     (message-from original-message)
 200                                     (actor-id from-actor) '*auto-reply*
 201                                     '()
 202                                     #:in-reply-to (message-id original-message))))
 203     (8sync (hive-process-message hive new-message))))
 204
 205 (define (<-reply-wait from-actor original-message . message-body-args)
 206   "Reply to a messsage, but wait until we get a response"
 207   (set-message-replied! original-message #t)
 208   (let* ((hive (actor-hive from-actor))
 209          (abort-to (hive-prompt (actor-hive from-actor)))
 210          (new-message (make-message (hive-gen-message-id hive)
 211                                     (message-from original-message)
 212                                     (actor-id from-actor) '*reply*
 213                                     message-body-args
 214                                     #:wants-reply #t
 215                                     #:in-reply-to (message-id original-message))))
 216     (abort-to-prompt abort-to from-actor new-message)))
 217
 218
 219 \f
 220 ;;; Main actor implementation
 221 ;;; =========================
 222
 223 (define-class <actor> ()
 224   ;; An address object
 225   (id #:init-keyword #:id
 226       #:getter actor-id)
 227   ;; The hive we're connected to.
 228   ;; We need this to be able to send messages.
 229   (hive #:init-keyword #:hive
 230         #:accessor actor-hive)
 231   ;; How we receive and process new messages
 232   (message-handler #:allocation #:each-subclass))
 233
 234 (define-method (actor-message-handler (actor <actor>))
 235   (slot-ref actor 'message-handler))
 236
 237 ;;; So these are the nicer representations of addresses.
 238 ;;; However, they don't serialize so easily with scheme read/write, so we're
 239 ;;; using the simpler cons cell version below for now.
 240
 241 ;; (define-record-type <address>
 242 ;;   (make-address actor-id hive-id)  ; @@: Do we want the trailing -id?
 243 ;;   address?
 244 ;;   (actor-id address-actor-id)
 245 ;;   (hive-id address-hive-id))
 246 ;;
 247 ;; (set-record-type-printer!
 248 ;;  <address>
 249 ;;  (lambda (record port)
 250 ;;    (format port "<address: ~s@~s>"
 251 ;;            (address-actor-id record) (address-hive-id record))))
 252 ;;
 253
 254 (define (make-address actor-id hive-id)
 255   (cons actor-id hive-id))
 256
 257 (define (address-actor-id address)
 258   (car address))
 259
 260 (define (address-hive-id address)
 261   (cdr address))
 262
 263 (define (address->string address)
 264   (string-append (address-actor-id address) "@"
 265                  (address-hive-id address)))
 266
 267 (define-method (actor-id-actor (actor <actor>))
 268   "Get the actor id component of the actor-id"
 269   (address-actor-id (actor-id actor)))
 270
 271 (define-method (actor-id-hive (actor <actor>))
 272   "Get the hive id component of the actor-id"
 273   (address-hive-id (actor-id actor)))
 274
 275 (define-method (actor-id-string (actor <actor>))
 276   "Render the full actor id as a human-readable string"
 277   (address->string (actor-id actor)))
 278
 279
 280 \f
 281 ;;; Actor utilities
 282 ;;; ===============
 283
 284 (define (simple-dispatcher action-map)
 285   (lambda (actor message)
 286     (let* ((action (message-action message))
 287            (method (assoc-ref action-map action)))
 288       (if (not method)
 289           ;; @@: There's every possibility this should be handled in
 290           ;;  hive-process-message instead.
 291           (throw 'action-not-found
 292                  "No appropriate action handler found for actor"
 293                  #:action action
 294                  #:actor actor
 295                  #:message message
 296                  #:available-actions (map car action-map)))
 297       (apply method actor message (message-body message)))))
 298
 299 (define-syntax %expand-action-item
 300   (syntax-rules ()
 301     ((_ (action-name handler))
 302      (cons (quote action-name) handler))))
 303
 304 (define-syntax-rule (build-actions action-item ...)
 305   "Build a mapping of actions.  Same syntax as make-action-dispatch
 306 but this doesn't build the dispatcher for you (you probably want to
 307 pass it to simple-dispatcher).
 308
 309 The advantage here is that since this simply builds an alist, you can
 310 compose it with other action maps."
 311   (list (%expand-action-item action-item) ...))
 312
 313 (define-syntax make-action-dispatch
 314   (syntax-rules ()
 315     "Expand a list of action names and actions into an alist
 316
 317 You can use this like the following:
 318   (make-action-dispatch
 319    (cookies
 320     (lambda (actor message)
 321       (display \"I love cookies!\n\")))
 322    (party
 323     (lambda (actor message)
 324       (display \"Life of the party!\"))))
 325
 326 Alternately, if you'd like to skip the lambda, you could use the slightly
 327 more compact following syntax:
 328   (make-action-dispatch
 329    ((cookies actor message)
 330      (display \"I love cookies!\n\"))
 331    ((party actor message)
 332      (display \"Life of the party!\")))"
 333     ((make-action-dispatch action-item ...)
 334      (simple-dispatcher (build-actions action-item ...)))))
 335
 336 (define-syntax-rule (define-simple-actor class actions ...)
 337   (define-class class (<actor>)
 338     (message-handler
 339      #:init-value (make-action-dispatch actions ...)
 340      #:allocation #:each-subclass)))
 341
 342 \f
 343 ;;; The Hive
 344 ;;; ========
 345 ;;;   Every actor has a hive.  The hive is a kind of "meta-actor"
 346 ;;;   which routes all the rest of the actors in a system.
 347
 348 (define-generic hive-handle-failed-forward)
 349
 350 (define-class <hive> (<actor>)
 351   (actor-registry #:init-thunk make-hash-table
 352                   #:getter hive-actor-registry)
 353   (msg-id-generator #:init-thunk simple-message-id-generator
 354                     #:getter hive-msg-id-generator)
 355   ;; Ambassadors are used (or will be) for inter-hive communication.
 356   ;; These are special actors that know how to route messages to other hives.
 357   (ambassadors #:init-thunk make-weak-key-hash-table
 358                #:getter hive-ambassadors)
 359   ;; Waiting coroutines
 360   ;; This is a map from cons cell of message-id
 361   ;;   to a cons cell of (actor-id . coroutine)
 362   ;; @@: Should we have a <waiting-coroutine> record type?
 363   ;; @@: Should there be any way to clear out "old" coroutines?
 364   (waiting-coroutines #:init-thunk make-hash-table
 365                       #:getter hive-waiting-coroutines)
 366   ;; Message prompt
 367   ;; When actors send messages to each other they abort to this prompt
 368   ;; to send the message, then carry on their way
 369   (prompt #:init-thunk make-prompt-tag
 370           #:getter hive-prompt)
 371   (message-handler
 372    #:init-value
 373    (make-action-dispatch
 374     ;; This is in the case of an ambassador failing to forward a message...
 375     ;; it reports it back to the hive
 376     (*failed-forward* hive-handle-failed-forward))))
 377
 378 (define-method (hive-handle-failed-forward (hive <hive>) message)
 379   "Handle an ambassador failing to forward a message"
 380   'TODO)
 381
 382 (define* (make-hive #:key hive-id)
 383   (let ((hive (make <hive>
 384                 #:id (make-address
 385                       "hive" (or hive-id
 386                                  (big-random-number-string))))))
 387     ;; Set the hive's actor reference to itself
 388     (set! (actor-hive hive) hive)
 389     hive))
 390
 391 (define-method (hive-id (hive <hive>))
 392   (actor-id-hive hive))
 393
 394 (define-method (hive-gen-actor-id (hive <hive>) cookie)
 395   (make-address (if cookie
 396                     (string-append cookie "-" (big-random-number-string))
 397                     (big-random-number-string))
 398                 (hive-id hive)))
 399
 400 (define-method (hive-gen-message-id (hive <hive>))
 401   "Generate a message id using HIVE's message id generator"
 402   ((hive-msg-id-generator hive)))
 403
 404 (define-method (hive-resolve-local-actor (hive <hive>) actor-address)
 405   (hash-ref (hive-actor-registry hive) actor-address))
 406
 407 (define-method (hive-resolve-ambassador (hive <hive>) ambassador-address)
 408   (hash-ref (hive-ambassadors hive) ambassador-address))
 409
 410 (define-method (make-forward-request (hive <hive>) (ambassador <actor>) message)
 411   (make-message (hive-gen-message-id hive) (actor-id ambassador)
 412                 ;; If we make the hive not an actor, we could either switch this
 413                 ;; to #f or to the original actor...?
 414                 ;; Maybe some more thinking should be done on what should
 415                 ;; happen in case of failure to forward?  Handling ambassador failures
 416                 ;; seems like the primary motivation for the hive remaining an actor.
 417                 (actor-id hive)
 418                 '*forward*
 419                 `((original . ,message))))
 420
 421 (define-method (hive-reply-with-error (hive <hive>) original-message
 422                                       error-key error-args)
 423   ;; We only supply the error-args if the original sender is on the same hive
 424   (define (orig-actor-on-same-hive?)
 425     (equal? (hive-id hive)
 426             (address-hive-id (message-from original-message))))
 427   (set-message-replied! original-message #t)
 428   (let* ((new-message-body
 429           (if (orig-actor-on-same-hive?)
 430               `(#:original-message ,original-message
 431                 #:error-key ,error-key
 432                 #:error-args ,error-args)
 433               `(#:original-message ,original-message
 434                 #:error-key ,error-key)))
 435          (new-message (make-message (hive-gen-message-id hive)
 436                                     (message-from original-message)
 437                                     (actor-id hive) '*error*
 438                                     new-message-body
 439                                     #:in-reply-to (message-id original-message))))
 440     (8sync (hive-process-message hive new-message))))
 441
 442 (define-method (hive-process-message (hive <hive>) message)
 443   "Handle one message, or forward it via an ambassador"
 444   (define (maybe-autoreply actor)
 445     ;; Possibly autoreply
 446     (if (message-needs-reply? message)
 447         (<-auto-reply actor message)))
 448
 449   (define (resolve-actor-to)
 450     "Get the actor the message was aimed at"
 451     (let ((actor (hive-resolve-local-actor hive (message-to message))))
 452       (if (not actor)
 453           (throw 'actor-not-found
 454                  (format #f "Message ~a from ~a directed to nonexistant actor ~a"
 455                          (message-id message)
 456                          (address->string (message-from message))
 457                          (address->string (message-to message)))
 458                  message))
 459       actor))
 460
 461   (define (call-catching-coroutine thunk)
 462     (define (call-catching-errors)
 463       ;; TODO: maybe parameterize (or attach to hive) and use
 464       ;;   maybe-catch-all from agenda.scm
 465       ;; @@: Why not just use with-throw-handler and let the catch
 466       ;;   happen at the agenda?  That's what we used to do, but
 467       ;;   it ended up with a SIGABRT.  See:
 468       ;;     http://lists.gnu.org/archive/html/bug-guile/2016-05/msg00003.html
 469       (catch #t
 470         thunk
 471         ;; In the actor model, we don't totally crash on errors.
 472         (lambda _ #f)
 473         ;; If an error happens, we raise it
 474         (lambda (key . args)
 475           (if (message-needs-reply? message)
 476               ;; If the message is waiting on a reply, let them know
 477               ;; something went wrong.
 478               (hive-reply-with-error hive message key args))
 479           ;; print error message
 480           (apply print-error-and-continue key args))))
 481     (call-with-prompt (hive-prompt hive)
 482       call-catching-errors
 483       (lambda (kont actor message)
 484         ;; Register the coroutine
 485         (hash-set! (hive-waiting-coroutines hive)
 486                    (message-id message)
 487                    (cons (actor-id actor) kont))
 488         ;; Send off the message
 489         (8sync (hive-process-message hive message)))))
 490
 491   (define (process-local-message)
 492     (let ((actor (resolve-actor-to)))
 493       (call-catching-coroutine
 494        (lambda ()
 495          (define message-handler (actor-message-handler actor))
 496          ;; @@: Should a more general error handling happen here?
 497          (let ((result
 498                 (message-handler actor message)))
 499            (maybe-autoreply actor)
 500            ;; Returning result allows actors to possibly make a run-request
 501            ;; at the end of handling a message.
 502            ;; ... We do want that, right?
 503            result)))))
 504
 505   (define (resume-waiting-coroutine)
 506     (cond
 507      ((or (eq? (message-action message) '*reply*)
 508           (eq? (message-action message) '*auto-reply*))
 509       (call-catching-coroutine
 510        (lambda ()
 511          (match (hash-remove! (hive-waiting-coroutines hive)
 512                               (message-in-reply-to message))
 513            ((_ . (resume-actor-id . kont))
 514             (if (not (equal? (message-to message)
 515                              resume-actor-id))
 516                 (throw 'resuming-to-wrong-actor
 517                        "Attempted to resume a coroutine to the wrong actor!"
 518                        #:expected-actor-id (message-to message)
 519                        #:got-actor-id resume-actor-id
 520                        #:message message))
 521             (let (;; @@: How should we resolve resuming coroutines to actors who are
 522                   ;;   now gone?
 523                   (actor (resolve-actor-to))
 524                   (result (kont message)))
 525               (maybe-autoreply actor)
 526               result))
 527            (#f (throw 'no-waiting-coroutine
 528                       "message in-reply-to tries to resume nonexistent coroutine"
 529                       message))))))
 530      ;; Yikes, we must have gotten an error or something back
 531      (else
 532       ;; @@: Not what we want in the long run?
 533       ;; What we'd *prefer* to do is to resume this message
 534       ;; and throw an error inside the message handler
 535       ;; (say, from send-mesage-wait), but that causes a SIGABRT (??!!)
 536       (hash-remove! (hive-waiting-coroutines hive)
 537                     (message-in-reply-to message))
 538       (let ((explaination
 539              (if (eq? (message-action message) '*reply*)
 540                  "Won't resume coroutine; got an *error* as a reply"
 541                  "Won't resume coroutine because action is not *reply*")))
 542         (throw 'hive-unresumable-coroutine
 543                explaination
 544                #:message message)))))
 545
 546   (define (process-remote-message)
 547     ;; Find the ambassador
 548     (let* ((remote-hive-id (hive-id (message-to message)))
 549            (ambassador (hive-resolve-ambassador remote-hive-id))
 550            (message-handler (actor-message-handler ambassador))
 551            (forward-request (make-forward-request hive ambassador message)))
 552       (message-handler ambassador forward-request)))
 553
 554   (let ((to (message-to message)))
 555     ;; This seems to be an easy mistake to make, so check that addressing
 556     ;; is correct here
 557     (if (not to)
 558         (throw 'missing-addressee
 559                "`to' field is missing on message"
 560                #:message message))
 561     (if (hive-actor-local? hive to)
 562         (if (message-in-reply-to message)
 563             (resume-waiting-coroutine)
 564             (process-local-message))
 565         (process-remote-message))))
 566
 567 (define-method (hive-actor-local? (hive <hive>) address)
 568   (equal? (hive-id hive) (address-hive-id address)))
 569
 570 (define-method (hive-register-actor! (hive <hive>) (actor <actor>))
 571   (hash-set! (hive-actor-registry hive) (actor-id actor) actor))
 572
 573 (define-method (%hive-create-actor (hive <hive>) actor-class
 574                                    init id-cookie)
 575   "Actual method called by hive-create-actor.
 576
 577 Since this is a define-method it can't accept fancy define* arguments,
 578 so this gets called from the nicer hive-create-actor interface.  See
 579 that method for documentation."
 580   (let* ((actor-id (hive-gen-actor-id hive id-cookie))
 581          (actor (apply make actor-class
 582                        #:hive hive
 583                        #:id actor-id
 584                        init)))
 585     (hive-register-actor! hive actor)
 586     ;; return the actor id
 587     actor-id))
 588
 589 (define* (hive-create-actor hive actor-class #:rest init)
 590   (%hive-create-actor hive actor-class
 591                       init #f))
 592
 593 (define* (hive-create-actor* hive actor-class id-cookie #:rest init)
 594   (%hive-create-actor hive actor-class
 595                       init id-cookie))
 596
 597 (define (call-with-message message proc)
 598   "Applies message body arguments into procedure, with message as first
 599 argument.  Similar to call-with-values in concept."
 600   (apply proc message (message-body message)))
 601
 602 ;; (msg-receive (<- bar baz)
 603 ;;     (baz)
 604 ;;   basil)
 605
 606 ;; Emacs: (put 'msg-receive 'scheme-indent-function 2)
 607
 608 ;; @@: Or receive-msg or receieve-message or??
 609 (define-syntax-rule (msg-receive arglist the-message body ...)
 610   (call-with-message the-message
 611                      (lambda* arglist
 612                        body ...)))
 613
 614 ;; Emacs: (put '=> 'scheme-indent-function 2)
 615 ;;; An experimental alias.
 616 (define-syntax-rule (=> rest ...)
 617   (msg-receive rest ...))
 618
 619
 620 \f
 621 ;;; Various API methods for actors to interact with the system
 622 ;;; ==========================================================
 623
 624 ;; TODO: move send-message and friends here...?
 625
 626 (define* (create-actor from-actor actor-class #:rest init)
 627   "Create an instance of actor-class.  Return the new actor's id.
 628
 629 This is the method actors should call directly (unless they want
 630 to supply an id-cookie, in which case they should use
 631 create-actor*)."
 632   (%hive-create-actor (actor-hive from-actor) actor-class
 633                       init #f))
 634
 635
 636 (define* (create-actor* from-actor actor-class id-cookie #:rest init)
 637   "Create an instance of actor-class.  Return the new actor's id.
 638
 639 Like create-actor, but permits supplying an id-cookie."
 640   (%hive-create-actor (actor-hive from-actor) actor-class
 641                       init id-cookie))
 642
 643
 644 (define (self-destruct actor)
 645   "Remove an actor from the hive."
 646   (hash-remove! (hive-actor-registry (actor-hive actor))
 647                 (actor-id actor)))
 648
 649
 650 \f
 651 ;;; 8sync bootstrap utilities
 652 ;;; =========================
 653
 654 (define* (ez-run-hive hive initial-tasks #:key repl-server)
 655   "Start up an agenda and run HIVE in it with INITIAL-TASKS.
 656
 657 Should we start up a cooperative REPL for live hacking?  REPL-SERVER
 658 wants to know!  You can pass it #t or #f, or if you want to specify a port,
 659 an integer."
 660   (let* ((queue (list->q initial-tasks))
 661          (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
 662                               #:queue queue)))
 663     (cond
 664      ;; If repl-server is an integer, we'll use that as the port
 665      ((integer? repl-server)
 666       (spawn-and-queue-repl-server! agenda repl-server))
 667      (repl-server
 668       (spawn-and-queue-repl-server! agenda)))
 669     (start-agenda agenda)))
 670
 671 (define (bootstrap-message hive to-id action . message-body-args)
 672   (wrap
 673    (apply <- hive to-id action message-body-args)))
 674
 675
 676 \f
 677 ;;; Basic readers / writers
 678 ;;; =======================
 679
 680 (define (serialize-message message)
 681   "Serialize a message for read/write"
 682   (list
 683    (message-id message)
 684    (message-to message)
 685    (message-from message)
 686    (message-action message)
 687    (message-body message)
 688    (message-in-reply-to message)
 689    (message-wants-reply message)
 690    (message-replied message)))
 691
 692 (define* (write-message message #:optional (port (current-output-port)))
 693   "Write out a message to a port for easy reading later.
 694
 695 Note that if a sub-value can't be easily written to something
 696 Guile's `read' procedure knows how to read, this doesn't do anything
 697 to improve that.  You'll need a better serializer for that.."
 698   (write (serialize-message message) port))
 699
 700 (define (serialize-message-pretty message)
 701   "Serialize a message in a way that's easy for humans to read."
 702   `(*message*
 703     (id ,(message-id message))
 704     (to ,(message-to message))
 705     (from ,(message-from message))
 706     (action ,(message-action message))
 707     (body ,(message-body message))
 708     (in-reply-to ,(message-in-reply-to message))
 709     (wants-reply ,(message-wants-reply message))
 710     (replied ,(message-replied message))))
 711
 712 (define (pprint-message message)
 713   "Pretty print a message."
 714   (pretty-print (serialize-message-pretty message)))
 715
 716 (define* (read-message #:optional (port (current-input-port)))
 717   "Read a message serialized via serialize-message from PORT"
 718   (match (read port)
 719     ((id to from action body in-reply-to wants-reply replied)
 720      (make-message-intern
 721       id to from action body
 722       in-reply-to wants-reply replied))
 723     (anything-else
 724      (throw 'message-read-bad-structure
 725             "Could not read message from structure"
 726             anything-else))))
 727
 728 (define (read-message-from-string message-str)
 729   "Read message from MESSAGE-STR"
 730   (with-input-from-string message-str
 731     (lambda ()
 732       (read-message (current-input-port)))))