2018-04-29 13:54:14 +00:00
|
|
|
#lang racket/base
|
|
|
|
;; Cross-layer relaying between adjacent dataspaces
|
|
|
|
;; TODO: protocol for *clean* shutdown of a dataspace
|
|
|
|
|
2018-05-02 12:19:18 +00:00
|
|
|
;; 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.)
|
|
|
|
|
2018-04-29 13:54:14 +00:00
|
|
|
(provide (struct-out inbound)
|
|
|
|
(struct-out outbound)
|
2018-05-01 19:58:43 +00:00
|
|
|
quit-dataspace!
|
2018-04-29 13:54:14 +00:00
|
|
|
dataspace)
|
|
|
|
|
|
|
|
(require racket/match)
|
|
|
|
(require racket/set)
|
|
|
|
(require "dataspace.rkt")
|
|
|
|
(require "syntax.rkt")
|
|
|
|
(require "skeleton.rkt")
|
|
|
|
(require "term.rkt")
|
|
|
|
(require "bag.rkt")
|
|
|
|
|
|
|
|
(require (for-syntax racket/base))
|
2018-04-29 15:07:49 +00:00
|
|
|
(require (for-syntax syntax/parse))
|
|
|
|
(require "syntax-classes.rkt")
|
2018-04-29 13:54:14 +00:00
|
|
|
|
|
|
|
(struct inbound (assertion) #:prefab)
|
|
|
|
(struct outbound (assertion) #:prefab)
|
|
|
|
|
2018-05-01 19:58:43 +00:00
|
|
|
(struct *quit-dataspace* () #:transparent)
|
|
|
|
|
2018-04-29 17:43:39 +00:00
|
|
|
;; TODO: inbound^n, outbound^n -- protocol/standard-relay, iow
|
|
|
|
|
2018-05-01 19:58:43 +00:00
|
|
|
(define (quit-dataspace!)
|
|
|
|
(send! (*quit-dataspace*)))
|
|
|
|
|
2018-04-29 13:54:14 +00:00
|
|
|
(define-syntax (dataspace stx)
|
2018-04-29 15:07:49 +00:00
|
|
|
(syntax-parse stx
|
|
|
|
[(_ name:name form ...)
|
2018-04-29 13:54:14 +00:00
|
|
|
(syntax/loc stx
|
2018-04-29 15:07:49 +00:00
|
|
|
(let ((ds-name name.N))
|
|
|
|
(spawn #:name ds-name
|
|
|
|
(define outer-facet (current-facet))
|
2018-05-01 19:58:43 +00:00
|
|
|
(begin/dataflow (void)) ;; eww. dummy endpoint to keep the root facet alive
|
2018-04-29 15:07:49 +00:00
|
|
|
(define (schedule-inner!)
|
|
|
|
(push-script!
|
2018-04-30 10:18:49 +00:00
|
|
|
(facet-actor outer-facet)
|
2018-04-29 15:07:49 +00:00
|
|
|
(lambda ()
|
2018-04-30 10:18:49 +00:00
|
|
|
(with-current-facet [outer-facet]
|
2018-05-01 19:58:43 +00:00
|
|
|
(when (facet-live? outer-facet)
|
|
|
|
(defer-turn! (lambda ()
|
|
|
|
(when (run-scripts! inner-ds)
|
|
|
|
(schedule-inner!)))))))))
|
2018-04-29 15:07:49 +00:00
|
|
|
(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!)))))]))
|
2018-04-29 13:54:14 +00:00
|
|
|
|
2018-04-30 10:18:49 +00:00
|
|
|
(define (boot-relay schedule-inner! outer-facet)
|
2018-04-29 13:54:14 +00:00
|
|
|
(define inbound-endpoints (make-hash))
|
|
|
|
(define outbound-endpoints (make-hash))
|
|
|
|
|
|
|
|
(define inner-actor (current-actor))
|
|
|
|
(define inner-facet (current-facet))
|
|
|
|
|
|
|
|
(on (asserted (observe (inbound $x)))
|
2018-04-29 15:08:35 +00:00
|
|
|
;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x)
|
2018-04-30 10:18:49 +00:00
|
|
|
(with-current-facet [outer-facet]
|
2018-04-30 09:44:35 +00:00
|
|
|
(with-non-script-context
|
|
|
|
(define i (skeleton-interest
|
|
|
|
(term->skeleton x)
|
|
|
|
(term->skeleton-proj x)
|
|
|
|
(term->key x)
|
|
|
|
(term->capture-proj x)
|
|
|
|
(lambda (op . captured-values)
|
|
|
|
(define term (inbound (instantiate-term->value x captured-values)))
|
2018-05-01 21:39:50 +00:00
|
|
|
;; (log-info "~a => ~a ~a ~v"
|
|
|
|
;; outer-facet
|
|
|
|
;; inner-facet
|
|
|
|
;; op
|
|
|
|
;; term)
|
2018-04-30 09:44:35 +00:00
|
|
|
(push-script! inner-actor
|
|
|
|
(lambda ()
|
|
|
|
;; (log-info "~a (~a) ~v" inner-actor op term)
|
|
|
|
(match op
|
|
|
|
['+ (adhoc-assert! inner-actor term)]
|
|
|
|
['- (adhoc-retract! inner-actor term)]
|
|
|
|
['! (enqueue-send! inner-actor term)])))
|
|
|
|
(schedule-inner!))
|
|
|
|
(lambda (cache)
|
|
|
|
(push-script! inner-actor
|
|
|
|
(lambda ()
|
|
|
|
(for [(captured-values (in-bag cache))]
|
|
|
|
(define term
|
|
|
|
(inbound (instantiate-term->value x captured-values)))
|
|
|
|
;; (log-info "~a (cleanup) ~v" inner-actor term)
|
|
|
|
(adhoc-retract! inner-actor term))))
|
|
|
|
(schedule-inner!))))
|
2018-05-02 17:10:52 +00:00
|
|
|
(add-endpoint-if-live! outer-facet
|
|
|
|
inbound-endpoints
|
|
|
|
x
|
|
|
|
"dataspace-relay (observe (inbound ...))"
|
|
|
|
(lambda () (values (observe x) i))))))
|
2018-04-29 13:54:14 +00:00
|
|
|
|
2018-05-01 19:58:43 +00:00
|
|
|
(on (message (*quit-dataspace*))
|
|
|
|
(with-current-facet [outer-facet]
|
|
|
|
(stop-current-facet)))
|
|
|
|
|
2018-04-29 13:54:14 +00:00
|
|
|
(on (retracted (observe (inbound $x)))
|
2018-04-29 15:08:35 +00:00
|
|
|
;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x)
|
2018-04-30 10:18:49 +00:00
|
|
|
(with-current-facet [outer-facet]
|
2018-04-30 09:44:35 +00:00
|
|
|
(with-non-script-context
|
|
|
|
(remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
|
|
|
|
(hash-remove! inbound-endpoints x))))
|
2018-04-29 13:54:14 +00:00
|
|
|
|
|
|
|
(on (asserted (outbound $x))
|
2018-04-29 15:08:35 +00:00
|
|
|
;; (log-info "~a (asserted (outbound ~v))" inner-actor x)
|
2018-04-30 10:18:49 +00:00
|
|
|
(with-current-facet [outer-facet]
|
2018-04-30 09:44:35 +00:00
|
|
|
(with-non-script-context
|
2018-05-02 17:10:52 +00:00
|
|
|
(add-endpoint-if-live! outer-facet
|
|
|
|
outbound-endpoints
|
|
|
|
x
|
|
|
|
"dataspace-relay (outbound ...)"
|
|
|
|
(lambda () (values x #f))))))
|
2018-04-29 13:54:14 +00:00
|
|
|
|
|
|
|
(on (retracted (outbound $x))
|
2018-04-29 15:08:35 +00:00
|
|
|
;; (log-info "~a (retracted (outbound ~v))" inner-actor x)
|
2018-04-30 10:18:49 +00:00
|
|
|
(with-current-facet [outer-facet]
|
2018-04-30 09:44:35 +00:00
|
|
|
(with-non-script-context
|
|
|
|
(remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
|
|
|
|
(hash-remove! outbound-endpoints x))))
|
2018-04-29 13:54:14 +00:00
|
|
|
|
|
|
|
(on (message (outbound $x))
|
2018-04-29 15:08:35 +00:00
|
|
|
;; (log-info "~a (message (outbound ~v))" inner-actor x)
|
2018-04-30 10:18:49 +00:00
|
|
|
(with-current-facet [outer-facet]
|
2018-04-29 13:54:14 +00:00
|
|
|
(send! x))))
|
2018-05-02 17:10:52 +00:00
|
|
|
|
|
|
|
(define (add-endpoint-if-live! f table key desc update-fn)
|
|
|
|
(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 (add-endpoint! f desc #t update-fn))))
|