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