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