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