100 lines
4.0 KiB
Racket
100 lines
4.0 KiB
Racket
#lang syndicate
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(provide (all-from-out syndicate/drivers/stream)
|
|
(all-from-out syndicate/schemas/gen/tcp))
|
|
|
|
(require racket/async-channel)
|
|
(require racket/tcp)
|
|
(require (only-in racket/exn exn->string))
|
|
(require syndicate/driver-support)
|
|
(require syndicate/functional-queue)
|
|
(require syndicate/pattern)
|
|
(require syndicate/drivers/stream)
|
|
(require syndicate/schemas/gen/tcp)
|
|
(require syndicate/schemas/gen/dataspace-patterns)
|
|
|
|
(require (for-syntax racket/base))
|
|
|
|
(define-logger syndicate/drivers/tcp)
|
|
|
|
(provide-service [ds]
|
|
(with-services [syndicate/drivers/stream]
|
|
(at ds
|
|
(during/spawn (StreamListener (TcpLocal $host $port) $peer)
|
|
#:name (TcpLocal host port)
|
|
(run-listener ds peer host port))
|
|
|
|
(during/spawn (StreamConnect (TcpRemote $host $port) $peer)
|
|
#:name (TcpRemote host port)
|
|
(run-outbound ds peer host port)))))
|
|
|
|
(define (run-listener ds peer host port)
|
|
(on-start (log-syndicate/drivers/tcp-info "+listener on ~v ~v" host port))
|
|
(on-stop (log-syndicate/drivers/tcp-info "-listener on ~v ~v" host port))
|
|
(linked-thread
|
|
#:name (list 'listen-thread host port)
|
|
(lambda (facet)
|
|
(with-connection-error-guard ds peer
|
|
(lambda (message)
|
|
(turn! facet (lambda ()
|
|
(at ds (assert (TcpListenError (TcpLocal host port) message)))
|
|
(at peer (assert (ConnectionHandler-rejected message))))))
|
|
(lambda ()
|
|
(define listener (tcp-listen port 512 #t host))
|
|
(lambda ()
|
|
(let loop ()
|
|
(define connection-custodian (make-custodian))
|
|
(define-values (i o) (parameterize ((current-custodian connection-custodian))
|
|
(tcp-accept listener)))
|
|
(turn! facet (lambda () (spawn-connection ds connection-custodian i o peer)))
|
|
(loop))))))))
|
|
|
|
(define (tcp-ends p)
|
|
(call-with-values (lambda () (tcp-addresses p #t))
|
|
(lambda (lh lp rh rp) (list (TcpLocal lh lp) (TcpRemote rh rp)))))
|
|
|
|
(define (spawn-connection ds custodian i o peer)
|
|
(match-define (and ends (list (and local-end (TcpLocal local-host local-port))
|
|
(and remote-end (TcpRemote remote-host remote-port))))
|
|
(tcp-ends i))
|
|
(define name (format "[~a:~a::~a:~a]" local-host local-port remote-host remote-port))
|
|
(log-syndicate/drivers/tcp-info "Connection ~a established" name)
|
|
(spawn #:name name
|
|
(actor-add-exit-hook! this-actor (lambda ()
|
|
(close-input-port i)
|
|
(close-output-port o)))
|
|
|
|
(define-field facet-count 2)
|
|
(define source #f)
|
|
(define sink #f)
|
|
|
|
(react (on-stop (facet-count (- (facet-count) 1))
|
|
(close-input-port i))
|
|
(set! source (port-source i #:custodian custodian))
|
|
(at ds (assert (TcpPeerInfo source local-end remote-end))))
|
|
|
|
(react (on-stop (facet-count (- (facet-count) 1))
|
|
(close-output-port o))
|
|
(set! sink (port-sink o))
|
|
(at ds (assert (TcpPeerInfo sink local-end remote-end))))
|
|
|
|
(at peer
|
|
(assert #:when (positive? (facet-count))
|
|
(ConnectionHandler-connected source sink)))))
|
|
|
|
(define (with-connection-error-guard ds peer error-proc proc)
|
|
((with-handlers ([exn:fail:network? (lambda (e) (lambda () (error-proc (exn->string e))))])
|
|
(proc))))
|
|
|
|
(define (run-outbound ds peer host port)
|
|
(with-connection-error-guard ds peer
|
|
(lambda (message)
|
|
(at peer (assert (ConnectionHandler-rejected message))))
|
|
(lambda ()
|
|
(define connection-custodian (make-custodian))
|
|
(define-values (i o) (parameterize ((current-custodian connection-custodian))
|
|
(tcp-connect host port)))
|
|
(lambda () (spawn-connection ds connection-custodian i o peer)))))
|