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