65 lines
2.7 KiB
Racket
65 lines
2.7 KiB
Racket
#lang imperative-syndicate
|
|
|
|
(provide (struct-out server-poa)
|
|
(struct-out message-poa->server)
|
|
(struct-out message-server->poa)
|
|
(struct-out server-proposal)
|
|
(struct-out server-envelope))
|
|
|
|
(require "wire-protocol.rkt")
|
|
(require racket/set)
|
|
|
|
;; Internal connection protocol
|
|
(assertion-struct server-poa (connection-id scope)) ;; "Point of Attachment"
|
|
(assertion-struct message-poa->server (connection-id body))
|
|
(assertion-struct message-server->poa (connection-id body))
|
|
|
|
;; Internal isolation -- these are isomorphic to `to-server` and `from-server`!
|
|
;; (and, for that matter, to `outbound` and `inbound`!)
|
|
(assertion-struct server-proposal (scope body)) ;; suggestions (~ actions)
|
|
(assertion-struct server-envelope (scope body)) ;; decisions (~ events)
|
|
|
|
(spawn #:name 'server-factory
|
|
|
|
(during/spawn (server-poa _ _)
|
|
;; 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))))
|
|
|
|
(during/spawn (server-poa $id $scope)
|
|
(define endpoints (set))
|
|
|
|
(on (message (message-poa->server id (Assert $ep $a)))
|
|
(when (not (set-member? endpoints ep))
|
|
(set! endpoints (set-add endpoints ep))
|
|
(react
|
|
(on-stop (set! endpoints (set-remove endpoints ep)))
|
|
|
|
(field [assertion a])
|
|
|
|
(assert (server-proposal scope (assertion)))
|
|
|
|
(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)))
|
|
|
|
(on (message (message-poa->server id (Assert ep $new-a)))
|
|
(assertion new-a))
|
|
|
|
(stop-when (message (message-poa->server id (Clear ep)))))))
|
|
|
|
(on (message (message-poa->server id (Message $body)))
|
|
(send! (server-envelope scope body)))
|
|
|
|
(on (message (message-poa->server id (Ping)))
|
|
(send! (message-server->poa id (Pong))))))
|