syndicate-rkt/syndicate/relay.rkt

155 lines
6.5 KiB
Racket

#lang racket/base
;; Cross-layer relaying between adjacent dataspaces
;; TODO: protocol for *clean* shutdown of a dataspace
;; TODO: Actually elide the need for relays entirely, by allowing an
;; actor to manifest in multiple dataspaces (multiple
;; points-of-attachment), and by placing assertions and subscriptions
;; directly in the dataspace concerned. (Done naively, this would
;; avoid manifesting observed assertions in intermediate nested
;; dataspaces; but then, if anyone cared, they'd be observing the
;; tuples themselves - right?? Oh, maybe observing the observers would
;; be an, er, observable difference.)
(provide quit-dataspace!
dataspace)
(require racket/match)
(require racket/set)
(require "assertions.rkt")
(require "dataspace.rkt")
(require "syntax.rkt")
(require "skeleton.rkt")
(require "term.rkt")
(require "bag.rkt")
(require (for-syntax racket/base))
(require (for-syntax syntax/parse))
(require "syntax-classes.rkt")
(struct *quit-dataspace* () #:transparent)
;; TODO: inbound^n, outbound^n -- protocol/standard-relay, iow
(define (quit-dataspace!)
(send! (*quit-dataspace*)))
(define-syntax (dataspace stx)
(syntax-parse stx
[(_ name:name form ...)
(syntax/loc stx
(let ((ds-name name.N))
(spawn #:name ds-name
(define outer-facet (current-facet))
(begin/dataflow (void)) ;; eww. dummy endpoint to keep the root facet alive
(define (schedule-inner!)
(push-script!
(facet-actor outer-facet)
(lambda ()
(with-current-facet [outer-facet]
(when (facet-live? outer-facet)
(defer-turn! (lambda ()
(when (run-scripts! inner-ds)
(schedule-inner!)))))))))
(define inner-ds (make-dataspace
(lambda ()
(schedule-script!
(current-actor)
(lambda ()
(spawn #:name (list 'ds-link ds-name)
(boot-relay schedule-inner!
outer-facet))
(spawn* form ...))))))
(on-start (schedule-inner!)))))]))
(define (boot-relay schedule-inner! outer-facet)
(define inbound-endpoints (make-hash))
(define outbound-endpoints (make-hash))
(define inner-facet (current-facet))
(define inner-actor (current-actor))
(define inner-ds (actor-dataspace inner-actor))
(on (asserted (observe (inbound $x)))
;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x)
(with-current-facet [outer-facet]
(with-non-script-context
(define (make-endpoint)
(define inner-capture-proj
;; inner-capture-proj accounts for the extra (inbound ...) layer around
;; assertions
(let ((outer-capture-proj (term->capture-proj x)))
(map (lambda (p) (cons 0 p)) outer-capture-proj)))
(define (rebuild cs)
(instantiate-term->value (inbound x) cs
#:visibility-restriction-proj inner-capture-proj))
(define ((wrap f) cs)
(f (rebuild cs))
(schedule-inner!))
(add-raw-observer-endpoint!
(lambda () x)
#:on-add (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t +1))))
#:on-remove (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t -1))))
#:on-message (wrap (lambda (t) (send-assertion! (dataspace-routing-table inner-ds) t)))
#:cleanup (lambda (cache)
(apply-patch! inner-ds inner-actor (for/bag/count [(cs (in-bag cache))]
(values (rebuild cs) -1)))
(schedule-inner!))))
(record-endpoint-if-live! outer-facet inbound-endpoints x make-endpoint))))
(on (message (*quit-dataspace*))
(with-current-facet [outer-facet]
(stop-current-facet)))
(on (retracted (observe (inbound $x)))
;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x)
(with-current-facet [outer-facet]
(with-non-script-context
(remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
(hash-remove! inbound-endpoints x))))
(on (asserted (outbound $x))
;; (log-info "~a (asserted (outbound ~v))" inner-actor x)
(with-current-facet [outer-facet]
(with-non-script-context
(record-endpoint-if-live! outer-facet
outbound-endpoints
x
(lambda ()
(add-endpoint! outer-facet
"dataspace-relay (outbound ...)"
#t
(lambda () (values x #f))))))))
(on (retracted (outbound $x))
;; (log-info "~a (retracted (outbound ~v))" inner-actor x)
(with-current-facet [outer-facet]
(with-non-script-context
(remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
(hash-remove! outbound-endpoints x))))
(on (message (outbound $x))
;; (log-info "~a (message (outbound ~v))" inner-actor x)
(with-current-facet [outer-facet]
(send! x))))
(define (record-endpoint-if-live! f table key ep-adder)
(when (facet-live? f)
;;
;; ^ Check that `f` is still alive, because we're (carefully!!)
;; violating an invariant of `dataspace.rkt` by adding an endpoint
;; well after the construction of the facet we're in. We may be
;; executing this handler just after clean shutdown of the facet
;; by a `quit-dataspace!` request, and in that case we MUST NOT
;; add any further endpoints because their assertions will not get
;; removed, because cleanup (as part of `(quit)` processing) has
;; already been done.
;;
;; We don't have to do a similar check before calling
;; `remove-endpoint!`, because shortly after all (both) calls to
;; `destroy-endpoint!`, all destroyed endpoints are removed from
;; the `facet-endpoints` table, ensuring they won't be processed
;; again.
;;
(hash-set! table key (ep-adder))))