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