8sync/systems/actors.scm

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