2019-03-18 15:34:14 +00:00
|
|
|
#lang imperative-syndicate
|
|
|
|
|
2019-05-09 10:17:37 +00:00
|
|
|
(provide generic-client-session-facet)
|
2019-03-18 23:29:12 +00:00
|
|
|
|
2019-03-18 15:34:14 +00:00
|
|
|
(require "wire-protocol.rkt")
|
2019-05-09 10:17:37 +00:00
|
|
|
(require "internal-protocol.rkt")
|
2019-03-18 15:34:14 +00:00
|
|
|
(require "protocol.rkt")
|
2019-03-18 23:29:12 +00:00
|
|
|
(require imperative-syndicate/term)
|
|
|
|
|
2019-05-05 15:51:23 +00:00
|
|
|
(define-logger syndicate/distributed)
|
2019-03-18 23:29:12 +00:00
|
|
|
|
|
|
|
(spawn #:name 'client-factory
|
2019-05-05 15:37:03 +00:00
|
|
|
(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))))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(define (generic-client-session-facet address scope w)
|
2019-05-05 15:51:23 +00:00
|
|
|
(on-start (log-syndicate/distributed-info "Connected to ~v" address))
|
|
|
|
(on-stop (log-syndicate/distributed-info "Disconnected from ~v" address))
|
2019-05-05 15:37:03 +00:00
|
|
|
(assert (server-connected address))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(on-start (w (Connect scope)))
|
|
|
|
|
2019-03-25 11:44:12 +00:00
|
|
|
(define next-ep
|
|
|
|
(let ((counter 0))
|
|
|
|
(lambda ()
|
|
|
|
(begin0 counter
|
|
|
|
(set! counter (+ counter 1))))))
|
|
|
|
|
2019-05-05 15:37:03 +00:00
|
|
|
(during (to-server address $a)
|
2019-03-25 11:44:12 +00:00
|
|
|
(define ep (next-ep))
|
|
|
|
(on-start (w (Assert ep a)))
|
|
|
|
(on-stop (w (Clear ep))))
|
|
|
|
|
2019-05-05 15:37:03 +00:00
|
|
|
(on (message (to-server address $a))
|
2019-03-25 11:44:12 +00:00
|
|
|
(w (Message a)))
|
|
|
|
|
2019-05-05 15:37:03 +00:00
|
|
|
(on (message (server-packet address (Ping)))
|
2019-03-25 11:44:12 +00:00
|
|
|
(w (Pong)))
|
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(on (message (server-packet address (Err $detail)))
|
|
|
|
(log-syndicate/distributed-error "Error from ~a: ~v" address detail)
|
|
|
|
(stop-current-facet))
|
|
|
|
|
2019-05-05 15:37:03 +00:00
|
|
|
(during (observe ($ pat (from-server address $spec)))
|
2019-03-25 11:44:12 +00:00
|
|
|
(define ep (next-ep))
|
|
|
|
(on-start (w (Assert ep (observe spec))))
|
|
|
|
(on-stop (w (Clear ep)))
|
2019-05-05 15:37:03 +00:00
|
|
|
(on (message (server-packet address (Add ep $vs)))
|
2019-03-25 16:32:09 +00:00
|
|
|
(react (assert (instantiate-term->value pat vs))
|
2019-05-05 15:37:03 +00:00
|
|
|
(stop-when (message (server-packet address (Del ep vs))))))
|
|
|
|
(on (message (server-packet address (Msg ep $vs)))
|
2019-03-25 16:32:09 +00:00
|
|
|
(send! (instantiate-term->value pat vs)))))
|