add-observer-endpoint!, add-raw-observer-endpoint!
This commit is contained in:
parent
dabc74976a
commit
a3a229532a
|
@ -31,22 +31,14 @@
|
||||||
|
|
||||||
(assert (server-envelope scope (assertion)))
|
(assert (server-envelope scope (assertion)))
|
||||||
|
|
||||||
(define (recompute-endpoint)
|
(let ((! (lambda (ctor) (lambda (cs) (send! (server-outbound id (ctor ep cs)))))))
|
||||||
(define a (assertion))
|
(add-observer-endpoint! (lambda ()
|
||||||
(if (observe? a)
|
(let ((a (assertion)))
|
||||||
(let ((spec (server-envelope scope (observe-specification a))))
|
(when (observe? a)
|
||||||
(values (observe spec)
|
(server-envelope scope (observe-specification a)))))
|
||||||
(term->skeleton-interest
|
#:on-add (! Add)
|
||||||
spec
|
#:on-remove (! Del)
|
||||||
(capture-facet-context
|
#:on-message (! Msg)))
|
||||||
(lambda (op . captured-values)
|
|
||||||
(schedule-script!
|
|
||||||
(current-actor)
|
|
||||||
(lambda ()
|
|
||||||
(define ctor (match op ['+ Add] ['- Del] ['! Msg]))
|
|
||||||
(send! (server-outbound id (ctor ep captured-values))))))))))
|
|
||||||
(values (void) #f)))
|
|
||||||
(add-endpoint! (current-facet) "server" #t recompute-endpoint)
|
|
||||||
|
|
||||||
(on (message (server-inbound id (Assert ep $new-a)))
|
(on (message (server-inbound id (Assert ep $new-a)))
|
||||||
(assertion new-a))
|
(assertion new-a))
|
||||||
|
|
|
@ -105,18 +105,12 @@
|
||||||
(during (router-connection node name)
|
(during (router-connection node name)
|
||||||
(on (message (router-outbound name (Subscribe $subid $spec)))
|
(on (message (router-outbound name (Subscribe $subid $spec)))
|
||||||
(react
|
(react
|
||||||
(define (update-fn)
|
(let ((! (lambda (ctor)
|
||||||
(values (observe (to-broker node spec))
|
(lambda (cs) (send! (router-inbound name (ctor subid cs)))))))
|
||||||
(term->skeleton-interest
|
(add-observer-endpoint! (lambda () (to-broker node spec))
|
||||||
(to-broker node spec)
|
#:on-add (! Add)
|
||||||
(capture-facet-context
|
#:on-remove (! Del)
|
||||||
(lambda (op . captures)
|
#:on-message (! Msg)))
|
||||||
(schedule-script!
|
|
||||||
(current-actor)
|
|
||||||
(lambda ()
|
|
||||||
(define ctor (match op ['+ Add] ['- Del] ['! Msg]))
|
|
||||||
(send! (router-inbound name (ctor subid captures))))))))))
|
|
||||||
(add-endpoint! (current-facet) "router" #f update-fn)
|
|
||||||
(assert (from-broker node (observe spec)))
|
(assert (from-broker node (observe spec)))
|
||||||
(stop-when (message (router-outbound name (Unsubscribe subid))))))
|
(stop-when (message (router-outbound name (Unsubscribe subid))))))
|
||||||
|
|
||||||
|
|
|
@ -77,23 +77,17 @@
|
||||||
(when (observe? assertion)
|
(when (observe? assertion)
|
||||||
(define pattern (observe-specification assertion))
|
(define pattern (observe-specification assertion))
|
||||||
(define x (mcds-outbound pattern))
|
(define x (mcds-outbound pattern))
|
||||||
(define i (term->skeleton-interest
|
(add-observer-endpoint!
|
||||||
x
|
(lambda () x)
|
||||||
(lambda (op . captured-values)
|
#:on-add
|
||||||
(when (eq? op '+)
|
(lambda (captured-values)
|
||||||
(define term
|
;; TODO: flawed?? Needs visibility-restriction, or some other way of
|
||||||
(instantiate-term->value pattern captured-values
|
;; ignoring the opaque placeholders!
|
||||||
#:visibility-restriction-proj #f))
|
(assert! (mcds-relevant (instantiate-term->value pattern
|
||||||
;; TODO: flawed?? Needs visibility-restriction, or some other way
|
captured-values
|
||||||
;; of ignoring the opaque placeholders!
|
#:visibility-restriction-proj
|
||||||
(schedule-script!
|
#f)
|
||||||
(current-actor)
|
peer)))))
|
||||||
(lambda ()
|
|
||||||
(assert! (mcds-relevant term peer))))))))
|
|
||||||
(add-endpoint! (current-facet)
|
|
||||||
"udp-dataspace (mcds-inbound (observe ...))"
|
|
||||||
#t
|
|
||||||
(lambda () (values (observe x) i))))
|
|
||||||
|
|
||||||
(stop-when (message (mcds-change peer '- assertion)))
|
(stop-when (message (mcds-change peer '- assertion)))
|
||||||
(stop-when (asserted (later-than expiry)))
|
(stop-when (asserted (later-than expiry)))
|
||||||
|
|
|
@ -74,44 +74,28 @@
|
||||||
;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x)
|
;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x)
|
||||||
(with-current-facet [outer-facet]
|
(with-current-facet [outer-facet]
|
||||||
(with-non-script-context
|
(with-non-script-context
|
||||||
(define i
|
(define (make-endpoint)
|
||||||
(let ((inner-capture-proj
|
(define inner-capture-proj
|
||||||
;; inner-capture-proj accounts for the extra (inbound ...) layer around
|
;; inner-capture-proj accounts for the extra (inbound ...) layer around
|
||||||
;; assertions
|
;; assertions
|
||||||
(let ((outer-capture-proj (term->capture-proj x)))
|
(let ((outer-capture-proj (term->capture-proj x)))
|
||||||
(map (lambda (p) (cons 0 p)) outer-capture-proj))))
|
(map (lambda (p) (cons 0 p)) outer-capture-proj)))
|
||||||
(term->skeleton-interest
|
(define (rebuild cs)
|
||||||
x
|
(instantiate-term->value (inbound x) cs
|
||||||
(lambda (op . captured-values)
|
#:visibility-restriction-proj inner-capture-proj))
|
||||||
(define assertion
|
(define ((wrap f) cs)
|
||||||
(instantiate-term->value (inbound x) captured-values
|
(f (rebuild cs))
|
||||||
#:visibility-restriction-proj inner-capture-proj))
|
(schedule-inner!))
|
||||||
;; (log-info "~a => ~a ~a ~v"
|
(add-raw-observer-endpoint!
|
||||||
;; outer-facet
|
(lambda () x)
|
||||||
;; inner-facet
|
#:on-add (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t +1))))
|
||||||
;; op
|
#:on-remove (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t -1))))
|
||||||
;; assertion)
|
#:on-message (wrap (lambda (t) (send-assertion! (dataspace-routing-table inner-ds) t)))
|
||||||
(match op
|
#:cleanup (lambda (cache)
|
||||||
['+ (apply-patch! inner-ds inner-actor (bag assertion +1))]
|
(apply-patch! inner-ds inner-actor (for/bag/count [(cs (in-bag cache))]
|
||||||
['- (apply-patch! inner-ds inner-actor (bag assertion -1))]
|
(values (rebuild cs) -1)))
|
||||||
['! (send-assertion! (dataspace-routing-table inner-ds) assertion)])
|
(schedule-inner!))))
|
||||||
(schedule-inner!))
|
(record-endpoint-if-live! outer-facet inbound-endpoints x make-endpoint))))
|
||||||
#:cleanup
|
|
||||||
(lambda (cache)
|
|
||||||
(apply-patch!
|
|
||||||
inner-ds
|
|
||||||
inner-actor
|
|
||||||
(for/bag/count [(captured-values (in-bag cache))]
|
|
||||||
;; (log-info "~a (cleanup) ~v" inner-actor term)
|
|
||||||
(values (instantiate-term->value (inbound x) captured-values
|
|
||||||
#:visibility-restriction-proj inner-capture-proj)
|
|
||||||
-1)))
|
|
||||||
(schedule-inner!)))))
|
|
||||||
(add-endpoint-if-live! outer-facet
|
|
||||||
inbound-endpoints
|
|
||||||
x
|
|
||||||
"dataspace-relay (observe (inbound ...))"
|
|
||||||
(lambda () (values (observe x) i))))))
|
|
||||||
|
|
||||||
(on (message (*quit-dataspace*))
|
(on (message (*quit-dataspace*))
|
||||||
(with-current-facet [outer-facet]
|
(with-current-facet [outer-facet]
|
||||||
|
@ -128,11 +112,14 @@
|
||||||
;; (log-info "~a (asserted (outbound ~v))" inner-actor x)
|
;; (log-info "~a (asserted (outbound ~v))" inner-actor x)
|
||||||
(with-current-facet [outer-facet]
|
(with-current-facet [outer-facet]
|
||||||
(with-non-script-context
|
(with-non-script-context
|
||||||
(add-endpoint-if-live! outer-facet
|
(record-endpoint-if-live! outer-facet
|
||||||
outbound-endpoints
|
outbound-endpoints
|
||||||
x
|
x
|
||||||
"dataspace-relay (outbound ...)"
|
(lambda ()
|
||||||
(lambda () (values x #f))))))
|
(add-endpoint! outer-facet
|
||||||
|
"dataspace-relay (outbound ...)"
|
||||||
|
#t
|
||||||
|
(lambda () (values x #f))))))))
|
||||||
|
|
||||||
(on (retracted (outbound $x))
|
(on (retracted (outbound $x))
|
||||||
;; (log-info "~a (retracted (outbound ~v))" inner-actor x)
|
;; (log-info "~a (retracted (outbound ~v))" inner-actor x)
|
||||||
|
@ -146,7 +133,7 @@
|
||||||
(with-current-facet [outer-facet]
|
(with-current-facet [outer-facet]
|
||||||
(send! x))))
|
(send! x))))
|
||||||
|
|
||||||
(define (add-endpoint-if-live! f table key desc update-fn)
|
(define (record-endpoint-if-live! f table key ep-adder)
|
||||||
(when (facet-live? f)
|
(when (facet-live? f)
|
||||||
;;
|
;;
|
||||||
;; ^ Check that `f` is still alive, because we're (carefully!!)
|
;; ^ Check that `f` is still alive, because we're (carefully!!)
|
||||||
|
@ -164,4 +151,4 @@
|
||||||
;; the `facet-endpoints` table, ensuring they won't be processed
|
;; the `facet-endpoints` table, ensuring they won't be processed
|
||||||
;; again.
|
;; again.
|
||||||
;;
|
;;
|
||||||
(hash-set! table key (add-endpoint! f desc #t update-fn))))
|
(hash-set! table key (ep-adder))))
|
||||||
|
|
|
@ -17,6 +17,8 @@
|
||||||
on-start
|
on-start
|
||||||
on-stop
|
on-stop
|
||||||
on
|
on
|
||||||
|
add-raw-observer-endpoint!
|
||||||
|
add-observer-endpoint!
|
||||||
during
|
during
|
||||||
during/spawn
|
during/spawn
|
||||||
begin/dataflow
|
begin/dataflow
|
||||||
|
@ -68,6 +70,7 @@
|
||||||
(require "event-expander.rkt")
|
(require "event-expander.rkt")
|
||||||
(require "skeleton.rkt")
|
(require "skeleton.rkt")
|
||||||
(require "pattern.rkt")
|
(require "pattern.rkt")
|
||||||
|
(require "term.rkt")
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
@ -240,6 +243,45 @@
|
||||||
(syntax/loc stx (begin/void-default script ...))
|
(syntax/loc stx (begin/void-default script ...))
|
||||||
#'prio.level)]))
|
#'prio.level)]))
|
||||||
|
|
||||||
|
(define (add-raw-observer-endpoint! spec-thunk
|
||||||
|
#:on-add [on-add void]
|
||||||
|
#:on-remove [on-remove void]
|
||||||
|
#:on-message [on-message void]
|
||||||
|
#:cleanup [cleanup #f])
|
||||||
|
(add-endpoint! (current-facet)
|
||||||
|
"add-observer-endpoint!/add-raw-observer-endpoint!"
|
||||||
|
#t
|
||||||
|
(lambda ()
|
||||||
|
(define spec (spec-thunk))
|
||||||
|
(if (void? spec)
|
||||||
|
(values (void) #f)
|
||||||
|
(values (observe spec)
|
||||||
|
(term->skeleton-interest
|
||||||
|
spec
|
||||||
|
(lambda (op . captured-values)
|
||||||
|
(match op
|
||||||
|
['+ (on-add captured-values)]
|
||||||
|
['- (on-remove captured-values)]
|
||||||
|
['! (on-message captured-values)]))
|
||||||
|
#:cleanup cleanup))))))
|
||||||
|
|
||||||
|
(define (add-observer-endpoint! spec-thunk
|
||||||
|
#:on-add [on-add void]
|
||||||
|
#:on-remove [on-remove void]
|
||||||
|
#:on-message [on-message void]
|
||||||
|
#:cleanup [cleanup #f])
|
||||||
|
(define (scriptify f)
|
||||||
|
(if (eq? f void)
|
||||||
|
void
|
||||||
|
(capture-facet-context
|
||||||
|
(lambda (captured-values)
|
||||||
|
(schedule-script! (current-actor) (lambda () (f captured-values)))))))
|
||||||
|
(add-raw-observer-endpoint! spec-thunk
|
||||||
|
#:on-add (scriptify on-add)
|
||||||
|
#:on-remove (scriptify on-remove)
|
||||||
|
#:on-message (scriptify on-message)
|
||||||
|
#:cleanup cleanup))
|
||||||
|
|
||||||
(define-syntax (begin/dataflow stx)
|
(define-syntax (begin/dataflow stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ prio:priority expr ...)
|
[(_ prio:priority expr ...)
|
||||||
|
|
Loading…
Reference in New Issue