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