#lang imperative-syndicate (provide generic-client-session-facet (struct-out server-packet) (struct-out server-transport-connected)) (require "wire-protocol.rkt") (require "protocol.rkt") (require imperative-syndicate/term) (define-logger syndicate/distributed) (spawn #:name 'client-factory (during (to-server $a _) (assert (server-connection a))) (during (observe (from-server $a _)) (assert (server-connection a))) (during (observe (server-connected $a)) (assert (server-connection a)))) ;; Received packets from server are relayed via one of these. (message-struct server-packet (address packet)) ;; Like `server-connected`, but for reflecting `tcp-accepted` to the ;; client end of a client-server connection without reordering wrt ;; `server-packet` messages. Implementation-facing, where ;; `server-connected` is part of the API. (assertion-struct server-transport-connected (address)) (define (generic-client-session-facet address scope w) (on-start (log-syndicate/distributed-info "Connected to ~v" address)) (on-stop (log-syndicate/distributed-info "Disconnected from ~v" address)) (assert (server-connected address)) (on-start (w (Connect scope))) (define next-ep (let ((counter 0)) (lambda () (begin0 counter (set! counter (+ counter 1)))))) (during (to-server address $a) (define ep (next-ep)) (on-start (w (Assert ep a))) (on-stop (w (Clear ep)))) (on (message (to-server address $a)) (w (Message a))) (on (message (server-packet address (Ping))) (w (Pong))) (on (message (server-packet address (Err $detail))) (log-syndicate/distributed-error "Error from ~a: ~v" address detail) (stop-current-facet)) (during (observe ($ pat (from-server address $spec))) (define ep (next-ep)) (on-start (w (Assert ep (observe spec)))) (on-stop (w (Clear ep))) (on (message (server-packet address (Add ep $vs))) (react (assert (instantiate-term->value pat vs)) (stop-when (message (server-packet address (Del ep vs)))))) (on (message (server-packet address (Msg ep $vs))) (send! (instantiate-term->value pat vs)))))