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