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-25 11:44:12 +00:00
|
|
|
|
|
|
|
(require "../client.rkt")
|
|
|
|
(require "../wire-protocol.rkt")
|
2019-05-09 10:17:37 +00:00
|
|
|
(require "../internal-protocol.rkt")
|
2019-03-25 11:44:12 +00:00
|
|
|
(require "../protocol.rkt")
|
2020-04-27 18:27:48 +00:00
|
|
|
(require syndicate/reassert)
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2020-04-27 18:27:48 +00:00
|
|
|
(require/activate syndicate/drivers/tcp)
|
2019-03-25 11:44:12 +00:00
|
|
|
|
|
|
|
(spawn #:name 'tcp-client-factory
|
2019-05-07 11:56:22 +00:00
|
|
|
(during/spawn (server-connection ($ address (server-tcp-connection $host $port $scope)))
|
2019-03-25 11:44:12 +00:00
|
|
|
#:name address
|
|
|
|
(define id (list (gensym 'client) host port))
|
2019-05-07 13:02:52 +00:00
|
|
|
|
|
|
|
(reassert-on (tcp-connection id (tcp-address host port))
|
|
|
|
(retracted (tcp-accepted id))
|
|
|
|
(asserted (tcp-rejected id _))
|
2019-06-20 10:55:29 +00:00
|
|
|
(retracted (server-transport-connected address))
|
2019-09-11 15:07:54 +00:00
|
|
|
(retracted (server-session-connected address)))
|
2019-05-07 13:02:52 +00:00
|
|
|
|
|
|
|
(during (tcp-accepted id)
|
2019-05-12 12:07:38 +00:00
|
|
|
(on-start (issue-unbounded-credit! tcp-in id))
|
2019-05-07 13:02:52 +00:00
|
|
|
(assert (server-transport-connected address))
|
|
|
|
(define accumulate! (packet-accumulator (lambda (p) (send! (server-packet address p)))))
|
|
|
|
(on (message (tcp-in id $bs)) (accumulate! bs)))
|
|
|
|
|
|
|
|
(during (server-transport-connected address)
|
|
|
|
;; If we run generic-client-session-facet in the `tcp-accepted` handler above, then
|
|
|
|
;; unfortunately disconnection of the TCP socket on error overtakes the error report
|
|
|
|
;; itself, terminating the generic-client-session-facet before it has a chance to
|
|
|
|
;; handle the error report.
|
|
|
|
;;
|
|
|
|
;; Could timing errors like that be something a type system could help us with? The
|
|
|
|
;; conversation in `server-packet`s is sort-of "nested" inside the conversation in
|
|
|
|
;; `tcp-in`s; a single facet reacting to both conversations (in this instance, to
|
|
|
|
;; `server-packets` in an implicit frame, but explicitly to the frame of the
|
|
|
|
;; `tcp-in`s, namely `tcp-accepted`) is probably an error. Or rather, any situation
|
|
|
|
;; where pending "inner conversation" business could be obliterated by discarding a
|
|
|
|
;; facet based on "outer conversation" framing is probably an error.
|
|
|
|
;;
|
|
|
|
(generic-client-session-facet address
|
|
|
|
scope
|
|
|
|
(lambda (x) (send! (tcp-out id (encode x))))))))
|