syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Test and fix for observation visibility in broker

This commit is contained in:
Tony Garnock-Jones 2019-05-03 17:53:24 +01:00
parent 83c81fa293
commit 40ee3b4ca7
2 changed files with 35 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
syndicate/broker/server.rkt
View File

@ -29,11 +29,12 @@
(field [assertion a])
(assert (server-envelope scope (assertion)))
(define (recompute-endpoint)
(define a (assertion))
(if (observe? a)
(let* ((pattern (observe-specification a))
(spec (server-envelope scope pattern)))
(let ((spec (server-envelope scope (observe-specification a))))
(values (observe spec)
(term->skeleton-interest
spec
@ -44,7 +45,7 @@
(lambda ()
(define ctor (match op ['+ Add] ['- Del] ['! Msg]))
(send! (server-outbound id (ctor ep captured-values))))))))))
(values (server-envelope scope a) #f)))
(values (void) #f)))
(add-endpoint! (current-facet) "server" #t recompute-endpoint)
(on (message (server-inbound id (Assert ep $new-a)))

31
syndicate/test/broker/observation-visibility.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang imperative-syndicate/test-implementation
;; A client observing some part of the server's dataspace should cause
;; creation of an assertion of observation in that server's dataspace.
(require (only-in imperative-syndicate/lang activate))
(require imperative-syndicate/broker)
(assertion-struct presence (who))
(define test-address (broker-loopback-connection "test"))
(test-case
[(activate imperative-syndicate/broker)
(spawn #:name 'producer
(during (broker-connected test-address)
(assert (to-broker test-address (presence 'producer)))))
(spawn #:name 'consumer
(during (broker-connected test-address)
(on (asserted (from-broker test-address (presence $who)))
(printf "~a joined\n" who))))
(spawn #:name 'metaconsumer
(during (broker-connected test-address)
(on (asserted (from-broker test-address (observe (presence _))))
(printf "Someone cares about presence!\n"))))
]
no-crashes
(expected-output (set "producer joined"
"Someone cares about presence!")))