89 lines
3.5 KiB
Racket
89 lines
3.5 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#lang syndicate
|
|
|
|
(require "wire-protocol.rkt")
|
|
(require "internal-protocol.rkt")
|
|
(require "turn.rkt")
|
|
|
|
(require/activate "heartbeat.rkt")
|
|
|
|
(spawn #:name 'server-factory
|
|
|
|
;; 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 clauses reflect this:
|
|
(on (asserted (server-proposal $scope $assertion))
|
|
(assert! (server-envelope scope assertion)))
|
|
(on (retracted (server-proposal $scope $assertion))
|
|
(retract! (server-envelope scope assertion)))
|
|
(on (message (server-proposal $scope $body))
|
|
(send! (server-envelope scope body)))
|
|
(on (asserted (observe (server-envelope $scope $spec)))
|
|
(assert! (server-proposal scope (observe spec))))
|
|
(on (retracted (observe (server-envelope $scope $spec)))
|
|
(retract! (server-proposal scope (observe spec))))
|
|
|
|
(during/spawn (server-poa $id)
|
|
(define root-facet (current-facet))
|
|
(assert (server-poa-ready id))
|
|
(on-start
|
|
(match (let-event [(message (message-poa->server id $p))] p)
|
|
[(Connect scope) (react (connected id scope root-facet))]
|
|
[_ (send! (message-server->poa id (Err 'connection-not-setup #f)))]))))
|
|
|
|
(define (connected id scope root-facet)
|
|
(define endpoints (hash))
|
|
|
|
(define turn (turn-recorder (lambda (items) (send! (message-server->poa id (Turn items))))))
|
|
|
|
(assert (server-active scope))
|
|
|
|
(define (send-error! detail [context #f])
|
|
(send! (message-server->poa id (Err detail context)))
|
|
(reset-turn! turn)
|
|
(stop-facet root-facet))
|
|
|
|
(define reset-heartbeat! (heartbeat (list 'server id scope)
|
|
(lambda (m) (send! (message-server->poa id m)))
|
|
(lambda () (stop-facet root-facet))))
|
|
|
|
(on (message (message-poa->server id $p))
|
|
(reset-heartbeat!)
|
|
(match p
|
|
[(Turn items)
|
|
(for [(item (in-list items))]
|
|
(match item
|
|
[(Assert ep a)
|
|
(if (hash-has-key? endpoints ep)
|
|
(send-error! 'duplicate-endpoint item)
|
|
(react
|
|
(define ep-facet (current-facet))
|
|
(set! endpoints (hash-set endpoints ep ep-facet))
|
|
(on-stop (set! endpoints (hash-remove endpoints ep)))
|
|
|
|
(assert (server-proposal scope a))
|
|
|
|
(when (observe? a)
|
|
(define ((! ctor) cs) (extend-turn! turn (ctor ep cs)))
|
|
(add-observer-endpoint!
|
|
(lambda () (server-envelope scope (observe-specification a)))
|
|
#:on-add (! Add)
|
|
#:on-remove (! Del)
|
|
#:on-message (! Msg)))))]
|
|
[(Clear ep)
|
|
(match (hash-ref endpoints ep #f)
|
|
[#f (send-error! 'nonexistent-endpoint item)]
|
|
[ep-facet (stop-facet ep-facet (extend-turn! turn (End ep)))])]
|
|
[(Message body)
|
|
(send! (server-proposal scope body))]))]
|
|
[(Ping)
|
|
(send! (message-server->poa id (Pong)))]
|
|
[(Pong)
|
|
(void)]
|
|
[_
|
|
(send-error! 'invalid-message p)])))
|