103 lines
3.9 KiB
Racket
103 lines
3.9 KiB
Racket
#lang racket/base
|
|
;; Cross-layer relaying between adjacent dataspaces
|
|
;; TODO: protocol for shutdown of a dataspace
|
|
;; TODO: protocol for *clean* shutdown of a dataspace
|
|
|
|
(provide (struct-out inbound)
|
|
(struct-out outbound)
|
|
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))
|
|
|
|
(struct inbound (assertion) #:prefab)
|
|
(struct outbound (assertion) #:prefab)
|
|
|
|
(define-syntax (dataspace stx)
|
|
(syntax-case stx ()
|
|
[(_ form ...)
|
|
(syntax/loc stx
|
|
(spawn (define outer-actor (current-actor))
|
|
(define outer-facet (current-facet))
|
|
(define inner-ds (make-dataspace
|
|
(lambda ()
|
|
(schedule-script!
|
|
(current-actor)
|
|
(lambda ()
|
|
(spawn #:name 'dataspace-relay
|
|
(boot-relay outer-actor
|
|
outer-facet))
|
|
(spawn* form ...))))))
|
|
(on-start (schedule-turn! inner-ds))))]))
|
|
|
|
(define (schedule-turn! inner-ds)
|
|
(defer-turn! (lambda ()
|
|
(when (run-scripts! inner-ds)
|
|
(schedule-turn! inner-ds)))))
|
|
|
|
(define (boot-relay outer-actor outer-facet)
|
|
(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)))
|
|
(with-current-facet [outer-actor outer-facet #f]
|
|
(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)))
|
|
(push-script! inner-actor
|
|
(lambda ()
|
|
(match op
|
|
['+ (adhoc-assert! inner-actor term)]
|
|
['- (adhoc-retract! inner-actor term)]
|
|
['! (enqueue-send! inner-actor term)]))))
|
|
(lambda (cache)
|
|
(push-script! inner-actor
|
|
(lambda ()
|
|
(for [(captured-values (in-bag cache))]
|
|
(define term
|
|
(inbound (instantiate-term->value x captured-values)))
|
|
(adhoc-retract! inner-actor term)))))))
|
|
(hash-set! inbound-endpoints
|
|
x
|
|
(add-endpoint! outer-facet
|
|
"dataspace-relay (observe (inbound ...))"
|
|
(lambda () (observe x))
|
|
i))))
|
|
|
|
(on (retracted (observe (inbound $x)))
|
|
(with-current-facet [outer-actor outer-facet #f]
|
|
(remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
|
|
(hash-remove! inbound-endpoints x)))
|
|
|
|
(on (asserted (outbound $x))
|
|
(with-current-facet [outer-actor outer-facet #f]
|
|
(hash-set! outbound-endpoints
|
|
x
|
|
(add-endpoint! outer-facet
|
|
"dataspace-relay (outbound ...)"
|
|
(lambda () x)
|
|
#f))))
|
|
|
|
(on (retracted (outbound $x))
|
|
(with-current-facet [outer-actor outer-facet #f]
|
|
(remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
|
|
(hash-remove! outbound-endpoints x)))
|
|
|
|
(on (message (outbound $x))
|
|
(with-current-facet [outer-actor outer-facet #f]
|
|
(send! x))))
|