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