2021-06-04 13:56:03 +00:00
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
2021-06-01 15:19:24 +00:00
|
|
|
|
2020-04-27 18:27:48 +00:00
|
|
|
#lang syndicate
|
2019-03-18 15:34:14 +00:00
|
|
|
|
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-06-11 17:33:37 +00:00
|
|
|
(require "turn.rkt")
|
2020-04-27 18:27:48 +00:00
|
|
|
(require syndicate/term)
|
2019-03-18 23:29:12 +00:00
|
|
|
|
2019-06-20 10:55:29 +00:00
|
|
|
(require/activate "heartbeat.rkt")
|
|
|
|
|
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-06-11 17:33:37 +00:00
|
|
|
(struct sub (spec [captures #:mutable]) #:transparent)
|
|
|
|
|
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-09-11 15:07:54 +00:00
|
|
|
(assert (server-session-connected address))
|
2019-05-20 20:45:40 +00:00
|
|
|
|
|
|
|
(when (log-level? syndicate/distributed-logger 'debug)
|
|
|
|
(set! w (let ((w* w))
|
|
|
|
(lambda (p)
|
|
|
|
(log-syndicate/distributed-debug "C OUT ~v ~v" address p)
|
|
|
|
(w* p)))))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-06-11 17:33:37 +00:00
|
|
|
(define turn (turn-recorder (lambda (items) (w (Turn items)))))
|
2019-05-07 11:56:22 +00:00
|
|
|
|
2019-03-25 11:44:12 +00:00
|
|
|
(define next-ep
|
|
|
|
(let ((counter 0))
|
|
|
|
(lambda ()
|
|
|
|
(begin0 counter
|
|
|
|
(set! counter (+ counter 1))))))
|
|
|
|
|
2019-06-11 17:33:37 +00:00
|
|
|
(define pubs (hash))
|
|
|
|
(define subs (hash))
|
|
|
|
(define matches (hash))
|
|
|
|
|
|
|
|
(on-start (w (Connect scope)))
|
|
|
|
(on-stop (for* [(s (in-hash-values matches)) (a (in-hash-values (sub-captures s)))] (retract! a)))
|
|
|
|
|
|
|
|
(define (instantiate s vs)
|
|
|
|
(instantiate-term->value (from-server address (sub-spec s)) vs))
|
|
|
|
|
|
|
|
(on (asserted (to-server address $a))
|
|
|
|
(define ep (next-ep))
|
|
|
|
(extend-turn! turn (Assert ep a))
|
|
|
|
(set! pubs (hash-set pubs a ep)))
|
|
|
|
|
|
|
|
(on (retracted (to-server address $a))
|
|
|
|
(define ep (hash-ref pubs a))
|
|
|
|
(extend-turn! turn (Clear ep))
|
|
|
|
(set! pubs (hash-remove pubs a)))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-05 15:37:03 +00:00
|
|
|
(on (message (to-server address $a))
|
2019-06-11 17:33:37 +00:00
|
|
|
(extend-turn! turn (Message a)))
|
|
|
|
|
|
|
|
(on (asserted (observe (from-server address $spec)))
|
|
|
|
(define ep (next-ep))
|
|
|
|
(extend-turn! turn (Assert ep (observe spec)))
|
|
|
|
(set! subs (hash-set subs spec ep))
|
|
|
|
(set! matches (hash-set matches ep (sub spec (hash)))))
|
|
|
|
|
|
|
|
(on (retracted (observe (from-server address $spec)))
|
|
|
|
(extend-turn! turn (Clear (hash-ref subs spec)))
|
|
|
|
(set! subs (hash-remove subs spec)))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-06-20 10:55:29 +00:00
|
|
|
(define reset-heartbeat! (heartbeat (list 'client address scope)
|
|
|
|
w
|
|
|
|
(lambda () (stop-current-facet))))
|
|
|
|
|
|
|
|
(on (message (server-packet address _))
|
|
|
|
(reset-heartbeat!))
|
|
|
|
|
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-06-11 23:23:39 +00:00
|
|
|
(on (message (server-packet address (Err $detail $context)))
|
|
|
|
(log-syndicate/distributed-error "Error from ~a: ~v~a"
|
|
|
|
address
|
|
|
|
detail
|
|
|
|
(if context
|
|
|
|
(format " ~v" context)
|
|
|
|
""))
|
2019-05-07 11:56:22 +00:00
|
|
|
(stop-current-facet))
|
|
|
|
|
2019-06-11 17:33:37 +00:00
|
|
|
(on (message (server-packet address (Turn $items)))
|
|
|
|
(for [(item (in-list items))]
|
|
|
|
(match item
|
|
|
|
[(Add ep vs) (let* ((s (hash-ref matches ep))
|
|
|
|
(a (instantiate s vs)))
|
|
|
|
(set-sub-captures! s (hash-set (sub-captures s) vs a))
|
|
|
|
(assert! a))]
|
|
|
|
[(Del ep vs) (let* ((s (hash-ref matches ep))
|
|
|
|
(a (hash-ref (sub-captures s) vs)))
|
|
|
|
(retract! a)
|
|
|
|
(set-sub-captures! s (hash-remove (sub-captures s) vs)))]
|
|
|
|
[(Msg ep vs) (let* ((s (hash-ref matches ep)))
|
|
|
|
(send! (instantiate s vs)))]
|
|
|
|
[(End ep) (let* ((s (hash-ref matches ep #f)))
|
|
|
|
(when s
|
|
|
|
(for [(a (in-hash-values (sub-captures s)))] (retract! a))
|
|
|
|
(set! matches (hash-remove matches ep))))]))))
|