8sync/systems/actors.scm

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