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