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