2019-03-18 15:34:14 +00:00
|
|
|
#lang imperative-syndicate
|
|
|
|
|
|
|
|
(require "wire-protocol.rkt")
|
2019-05-09 10:17:37 +00:00
|
|
|
(require "internal-protocol.rkt")
|
2019-03-25 11:44:12 +00:00
|
|
|
(require racket/set)
|
|
|
|
|
2019-05-05 15:37:03 +00:00
|
|
|
(spawn #:name 'server-factory
|
2019-05-05 11:55:16 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
;; Previously, we just had server-envelope. Now, we have both
|
|
|
|
;; server-envelope and server-proposal. While not everything
|
|
|
|
;; decided is (locally) suggested, it is true that everything
|
|
|
|
;; suggested is decided (in this implementation at least),
|
|
|
|
;; and the following clause reflects this:
|
|
|
|
(during (server-proposal $scope $assertion)
|
|
|
|
(assert (server-envelope scope assertion)))
|
2019-05-05 11:55:16 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(during/spawn (server-poa $id)
|
2019-05-09 10:17:37 +00:00
|
|
|
(on-start
|
|
|
|
(let-event [(message (message-poa->server id $p))]
|
|
|
|
(match p
|
|
|
|
[(Connect scope) (react (connected id scope))]
|
|
|
|
[(Peer scope) (react (assert (federated-link id scope)))]
|
|
|
|
[_ (send-error! id 'connection-not-setup)])))))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(define (send-error! id detail)
|
|
|
|
(send! (message-server->poa id (Err detail))))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(define (connected id scope)
|
|
|
|
(define endpoints (set))
|
2019-05-09 10:17:37 +00:00
|
|
|
(assert (server-active scope))
|
2019-05-07 11:56:22 +00:00
|
|
|
(on (message (message-poa->server id $p))
|
|
|
|
(match p
|
|
|
|
[(Assert ep a) #:when (not (set-member? endpoints ep))
|
|
|
|
(set! endpoints (set-add endpoints ep))
|
|
|
|
(react
|
|
|
|
(on-stop (set! endpoints (set-remove endpoints ep)))
|
2019-05-03 16:53:24 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(field [assertion a])
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(assert (server-proposal scope (assertion)))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(let ((! (lambda (ctor) (lambda (cs) (send! (message-server->poa id (ctor ep cs)))))))
|
|
|
|
(add-observer-endpoint! (lambda ()
|
|
|
|
(let ((a (assertion)))
|
|
|
|
(when (observe? a)
|
|
|
|
(server-envelope scope (observe-specification a)))))
|
|
|
|
#:on-add (! Add)
|
|
|
|
#:on-remove (! Del)
|
|
|
|
#:on-message (! Msg)))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(on (message (message-poa->server id (Assert ep $new-a)))
|
|
|
|
(assertion new-a))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(stop-when (message (message-poa->server id (Clear ep)))))]
|
|
|
|
[(Clear ep) #:when (set-member? endpoints ep)
|
|
|
|
(void)] ;; handled by stop-when clause in facet established by Assert handler
|
|
|
|
[(Message body)
|
|
|
|
(send! (server-envelope scope body))]
|
|
|
|
[other
|
|
|
|
(unhandled-message id other)])))
|
|
|
|
|
2019-05-09 10:17:37 +00:00
|
|
|
(define (unhandled-message id p)
|
|
|
|
(match p
|
|
|
|
[(Connect _) (send-error! id 'duplicate-connection-setup)]
|
|
|
|
[(Peer _) (send-error! id 'duplicate-connection-setup)]
|
|
|
|
[(Ping) (send! (message-server->poa id (Pong)))]
|
|
|
|
[_ (send-error! id 'invalid-message)]))
|