8sync/systems/actors.scm

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