Browse Source

Simpler stream connection protocol.

novy
Tony Garnock-Jones 3 months ago
parent
commit
28901e9d31
  1. 12
      syndicate-examples/tcp-client.rkt
  2. 26
      syndicate-examples/tcp-echo-server-explicit.rkt
  3. 2
      syndicate-examples/tcp-echo-server.rkt
  4. 2
      syndicate-examples/tcp-relay-server.rkt
  5. 2
      syndicate/distributed/tcp-server.rkt
  6. 130
      syndicate/drivers/stream.rkt
  7. 75
      syndicate/drivers/tcp.rkt
  8. 22
      syndicate/schemas/stream.prs
  9. 2
      syndicate/schemas/tcp.prs
  10. 8
      syndicate/syntax-classes.rkt
  11. 66
      syndicate/syntax.rkt

12
syndicate-examples/tcp-client.rkt

@ -22,12 +22,12 @@
(establish-connection
ds (TcpRemote host port)
#:initial-mode (Mode-lines (LineMode-lf))
#:on-connected (lambda (source sink)
(at ds
(on (message (RacketEvent (read-line-evt (current-input-port)) $vs))
(match (car vs)
[(? eof-object?) (stop-current-facet (log-info "EOF on stdin."))]
[line (send-line sink line)]))))
#:on-connect (lambda (source sink)
(at ds
(on (message (RacketEvent (read-line-evt (current-input-port)) $vs))
(match (car vs)
[(? eof-object?) (stop-current-facet (log-info "EOF on stdin."))]
[line (send-line sink line)]))))
#:on-rejected (lambda (message) (stop-current-facet (log-error "~a" message)))
#:on-disconnect (lambda () (stop-current-facet (log-info "Disconnected")))
#:on-data (lambda (line _mode)

26
syndicate-examples/tcp-echo-server-explicit.rkt

@ -1,26 +0,0 @@
#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(module+ main
(require racket/cmdline)
(require syndicate/drivers/tcp)
(define host "0.0.0.0")
(define port 5999)
(command-line #:once-each
[("--host" "-H") hostname "Set hostname to listen on"
(set! host hostname)]
[("--port" "-p") port-number "Set port number to listen on"
(set! port (string->number port-number))])
(standard-actor-system (ds)
(at ds
(assert (StreamListener (TcpLocal host port)
(make-connection-handler
(lambda (source sink)
(handle-connection source sink
#:on-data
(lambda (data mode)
(send-data sink data mode))))))))))

2
syndicate-examples/tcp-echo-server.rkt

@ -17,7 +17,7 @@
(standard-actor-system (ds)
(at ds
(stop-on (asserted (TcpListenError (TcpLocal host port) $message)))
(stop-on (asserted (StreamListenerError (TcpLocal host port) $message)))
(during/spawn (StreamConnection $source $sink (TcpLocal host port))
(handle-connection source sink
#:on-data (lambda (data mode) (send-data sink data mode)))))))

2
syndicate-examples/tcp-relay-server.rkt

@ -19,7 +19,7 @@
(standard-actor-system (ds)
(at ds
(stop-on (asserted (TcpListenError (TcpLocal host port) $message)))
(stop-on (asserted (StreamListenerError (TcpLocal host port) $message)))
(during/spawn (StreamConnection $source $sink (TcpLocal host port))
(handle-connection source sink
#:initial-mode (Mode-lines (LineMode-lf))

2
syndicate/distributed/tcp-server.rkt

@ -26,7 +26,7 @@
(define spec (TcpLocal "0.0.0.0" 5999))
(at ds
(stop-on (asserted (TcpListenError spec _)))
(stop-on (asserted (StreamListenerError spec _)))
(during/spawn (StreamConnection $source $sink spec)
#:name (list 'tcp-server source)
(run-relay #:packet-writer (lambda (bs) (send-data sink bs))

130
syndicate/drivers/stream.rkt

@ -7,7 +7,6 @@
port-source
port-sink
make-connection-handler
make-source
make-sink
handle-connection
@ -34,85 +33,25 @@
(require syndicate/service)
(require syndicate/pattern)
(require syndicate/driver-support)
(require syndicate/drivers/racket-event)
(require syndicate/schemas/gen/stream)
(define-logger syndicate/drivers/stream)
(provide-service [ds]
(at ds
(during/spawn (Observe (:pattern (StreamConnection ,_ ,_ ,$spec-pat)) _)
#:name (list 'stream-listener spec-pat)
(match (pattern->constant spec-pat)
[(? void?) (stop-current-facet)]
[spec (at ds
(during (StreamSpecListenable spec)
(assert
(StreamListener spec
(make-connection-handler
(lambda (source sink)
(assert (StreamConnection source sink spec))))))))]))
(during/spawn (StreamConnection $app-source $app-sink $spec)
#:name (list 'stream-connection spec)
(at ds
(during (StreamSpecConnectable spec)
(assert (StreamConnect spec
(object #:name 'connection-peer
[(ConnectionHandler-connected sys-source sys-sink)
(at sys-source (assert (Source-sink app-sink)))
(at sys-sink (assert (Sink-source app-source)))]
[(ConnectionHandler-rejected message)
(log-syndicate/drivers/stream-error
"Connection to ~a rejected: ~a" spec message)
(at app-source (assert (StreamError message)))
(at app-sink (assert (StreamError message)))
(stop-current-facet)]))))))
;; I translate interest in StreamListener with a particular spec-pattern into a facet
;; that reacts to interest in StreamSpecListenable with a spec matching the spec-pattern
;; by asserting StreamSpecListenable with that spec.
(during (Observe (:pattern (StreamListener ,$spec-pat ,_)) _)
(define listenable-asserter
(object [bindings
(define spec
(pattern->constant spec-pat (lambda (_name index) (list-ref bindings index))))
(assert (StreamSpecListenable spec))]))
(assert
(Observe (:pattern
(Observe (:pattern (StreamSpecListenable ,,(:pattern (DLit ,spec-pat)))) _))
listenable-asserter)))
;; I translate interest in StreamConnect with a particular spec-pattern into a facet that
;; reacts to interest in StreamSpecConnectable with a spec matching the spec-pattern by
;; asserting StreamSpecConnectable with that spec.
(during (Observe (:pattern (StreamConnect ,$spec-pat ,_)) _)
(define connectable-asserter
(object [bindings
(define spec
(pattern->constant spec-pat (lambda (_name index) (list-ref bindings index))))
(assert (StreamSpecConnectable spec))]))
(assert
(Observe (:pattern
(Observe (:pattern (StreamSpecConnectable ,,(:pattern (DLit ,spec-pat)))) _))
connectable-asserter)))))
(define (make-connection-handler on-connected #:name [name (gensym 'connection-handler)])
(object #:name name
[(ConnectionHandler-connected source sink)
(on-connected source sink)]
[(ConnectionHandler-rejected message)
(error 'connection-handler "~a" message)]))
;; No active components.
)
(define (port-source [port (current-input-port)]
#:initial-sink [initial-sink #f]
#:custodian [custodian #f]
#:name [name (list 'port-source (object-name port))])
(define active-sink #f)
(define active-sink initial-sink)
(define issue-credit (start-inbound-relay #:custodian custodian
(lambda () active-sink)
port))
(make-source #:name name
#:initial-sink initial-sink
#:on-connect (lambda (new-sink) (set! active-sink new-sink))
#:on-credit issue-credit))
@ -122,7 +61,7 @@
(define control-ch (make-async-channel))
(linked-thread
#:name (cons 'input-thread (object-name port))
#:name (list 'input-thread (object-name port))
#:custodian custodian
#:peer (object #:name 'inbound-relay-monitor
[#:asserted _
@ -196,12 +135,14 @@
issue-credit)
(define (port-sink [port (current-output-port)]
#:initial-source [initial-source #f]
#:initial-credit [initial-credit (CreditAmount-unbounded)]
#:initial-mode [initial-mode (Mode-bytes)]
#:name [name (list 'port-sink (object-name port))])
(define active-source #f)
(define active-source initial-source)
(define relay (outbound-relay port))
(make-sink #:name name
#:initial-source initial-source
#:on-connect
(lambda (new-source)
(set! active-source new-source)
@ -349,7 +290,7 @@
(define (establish-connection ds spec
#:name [name (gensym 'establish-connection)]
#:on-connected [on-connected (lambda (source sink) (void))]
#:on-connect [on-connect (lambda (source sink) (void))]
#:on-rejected [on-rejected #f]
#:on-disconnect [on-disconnect #f]
@ -359,24 +300,39 @@
#:initial-mode [initial-mode (Mode-bytes)]
#:on-data on-data
#:on-eof [on-eof void])
(define peer
(object #:name name
[#:asserted (ConnectionHandler-connected source sink)
(handle-connection source sink
#:on-disconnect on-disconnect
#:on-error on-error
#:on-credit on-credit
#:initial-credit initial-credit
#:initial-mode initial-mode
#:on-data on-data
#:on-eof on-eof)
(stop-facet ringing-facet)
(on-connected source sink)]
[#:asserted (ConnectionHandler-rejected message)
(stop-facet ringing-facet)
((or on-rejected (lambda (_message) (stop-current-facet))) message)]))
(define ringing-facet (react (at ds (assert (StreamConnect spec peer)))))
(void))
(define connection-state 'pending)
(begin/dataflow (log-info "connection-state ~a" connection-state))
(define (transition new-state)
(when (not (equal? connection-state new-state))
(match* (connection-state new-state)
[('pending 'connected)
(when initial-credit (send-credit (peer-source) initial-credit initial-mode))
(on-connect (peer-source) (peer-sink))]
[(_ 'disconnected)
(on-disconnect)]
[('pending (list 'error m))
(on-rejected m)]
[(_ (list 'error m))
(on-error m)])))
(define-field peer-source #f)
(define-field peer-sink #f)
(begin/dataflow
(when (and (peer-source) (peer-sink))
(transition 'connected)))
(define source (make-source #:name (list 'source name)
#:on-connect peer-sink
#:on-disconnect (lambda () (transition 'disconnected))
#:on-error (lambda (m) (transition (list 'error m)))
#:on-credit on-credit))
(define sink (make-sink #:name (list 'sink name)
#:on-connect peer-source
#:on-disconnect (lambda () (transition 'disconnected))
#:on-error (lambda (m) (transition (list 'error m)))
#:on-data on-data
#:on-eof on-eof))
(at ds (assert (StreamConnection source sink spec))))
;;---------------------------------------------------------------------------

75
syndicate/drivers/tcp.rkt

@ -22,45 +22,71 @@
(provide-service [ds]
(with-services [syndicate/drivers/stream]
(at ds
(during/spawn (StreamListener (TcpLocal $host $port) $peer)
;; TODO: this is annoying. We have to pay attention to the *syntactic* structure of the
;; listener's pattern in order to match all possible variants:
;; - `variable`, where `variable`'s value matches `(TcpLocal _ _)`
;; - `(TcpLocal variable1 variable2)`
;; - `(TcpLocal "hostname" variable)`
;; - `(TcpLocal variable 1234)`
;; - `(TcpLocal "hostname" 1234)`
;;
;; POSSIBLE SOLUTION: have pattern analysis check to see if there are any binds or
;; discards within a constructor application; if there are none, it may as well be a
;; constant literal, so make it one. This is what the earlier Syndicate/js
;; implementations do (because they don't have a compile-time constructor registry and
;; have to decide whether to assume a compound or just evaluate some expression), and it
;; works fine there.
(during/spawn (Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,$host-pat ,$port-pat))) _)
#:match [host (pattern->constant host-pat)]
#:match [port (pattern->constant port-pat)]
#:when (not (or (void? host) (void? port)))
#:name (TcpLocal host port)
(run-listener ds host port))
(during/spawn
(Observe (:pattern (StreamConnection ,_ ,_ ,(DLit (TcpLocal $host $port)))) _)
#:name (TcpLocal host port)
(run-listener ds peer host port))
(run-listener ds host port))
(during/spawn (StreamConnect (TcpRemote $host $port) $peer)
(during/spawn (StreamConnection $source $sink (TcpRemote $host $port))
#:name (TcpRemote host port)
(run-outbound ds peer host port)))))
(run-outbound ds source sink 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))
(define (run-listener ds host port)
(define spec (TcpLocal host port))
(on-start (log-syndicate/drivers/tcp-info "+listener on ~v" spec))
(on-stop (log-syndicate/drivers/tcp-info "-listener on ~v" spec))
(linked-thread
#:name (list 'listen-thread host port)
(lambda (facet)
(with-connection-error-guard ds peer
(with-connection-error-guard ds
(lambda (message)
(turn! facet (lambda ()
(at ds (assert (TcpListenError (TcpLocal host port) message)))
(at peer (assert (ConnectionHandler-rejected message))))))
(log-syndicate/drivers/tcp-warning "~a" message)
(at ds (assert (StreamListenerError spec message))))))
(lambda ()
(define listener (tcp-listen port 512 #t host))
(lambda ()
(turn! facet (lambda ()
(at ds (assert (StreamListenerReady spec)))))
(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)))
(turn! facet (lambda () (spawn-connection ds connection-custodian i o spec #f #f)))
(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)
(define (spawn-connection ds custodian i o spec peer-source peer-sink)
(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)
(log-syndicate/drivers/tcp-info "TCP socket ~a for ~a established" name spec)
(spawn #:name name
(actor-add-exit-hook! this-actor (lambda ()
(close-input-port i)
@ -72,28 +98,31 @@
(react (on-stop (facet-count (- (facet-count) 1))
(close-input-port i))
(set! source (port-source i #:custodian custodian))
(set! source (port-source i #:initial-sink peer-sink #: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))
(set! sink (port-sink o #:initial-source peer-source))
(at ds (assert (TcpPeerInfo sink local-end remote-end))))
(at peer
(assert #:when (positive? (facet-count))
(ConnectionHandler-connected source sink)))))
(when (TcpLocal? spec)
(at ds
(assert #:when (positive? (facet-count)) (StreamConnection source sink spec))))))
(define (with-connection-error-guard ds peer error-proc proc)
(define (with-connection-error-guard ds 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
(define (run-outbound ds source sink host port)
(with-connection-error-guard ds
(lambda (message)
(at peer (assert (ConnectionHandler-rejected message))))
(log-syndicate/drivers/tcp-warning "~a" message)
(at source (assert (StreamError message)))
(at sink (assert (StreamError 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)))))
(lambda ()
(spawn-connection ds connection-custodian i o (TcpRemote host port) source sink)))))

22
syndicate/schemas/stream.prs

@ -1,24 +1,14 @@
version 1 .
embeddedType EntityRef.Ref .
; Assertions
; Assertion:
StreamConnection = <stream-connection @source #!Source @sink #!Sink @spec any>.
StreamSpecListenable = <stream-spec-listenable @spec any>.
StreamSpecConnectable = <stream-spec-connectable @spec any>.
; Assertion
StreamListener = <stream-listener @spec any @handle #!ConnectionHandler>.
; Assertions:
StreamListenerReady = <stream-listener-ready @spec any>.
StreamListenerError = <stream-listener-error @spec any @message string>.
; Assertion
StreamConnect = <stream-connect @spec any @handle #!ConnectionHandler>.
; Assertion
ConnectionHandler =
/ @connected <stream-connected @source #!Source @sink #!Sink>
/ @rejected <stream-rejected @message string>
.
; Assertion
; Assertion:
StreamError = <error @message string>.
Source =
@ -40,7 +30,9 @@ Sink =
/ <eof>
.
; Value:
CreditAmount = @count int / @unbounded =unbounded .
; Value:
Mode = =bytes / @lines LineMode / <packet @size int> / <object @description any>.
LineMode = =lf / =crlf .

2
syndicate/schemas/tcp.prs

@ -5,5 +5,3 @@ TcpRemote = <tcp-remote @host string @port int>.
TcpLocal = <tcp-local @host string @port int>.
TcpPeerInfo = <tcp-peer @handle #!any @local TcpLocal @remote TcpRemote>.
TcpListenError = <tcp-listen-error @spec TcpLocal @message string>.

8
syndicate/syntax-classes.rkt

@ -5,7 +5,8 @@
(provide (for-syntax <when>
<name>
<daemon?>
<link?>))
<link?>
<matches>))
(require (for-syntax racket/base))
(require (for-syntax syntax/parse))
@ -25,4 +26,7 @@
(define-splicing-syntax-class <link?>
(pattern (~seq #:link? L))
(pattern (~seq) #:attr L #'#f)))
(pattern (~seq) #:attr L #'#f))
(define-splicing-syntax-class <matches>
(pattern (~seq (~seq #:match [pattern-pieces ...+ discriminant]) ...))))

66
syndicate/syntax.rkt

@ -212,8 +212,10 @@
(define-syntax-rule (on-stop expr ...)
(facet-on-stop! this-facet (lambda () expr ...)))
(define-syntax-rule (sync! peer expr ...)
(turn-sync! this-turn peer (lambda (_reply) expr ...)))
(define-syntax (sync! stx)
(syntax-parse stx
[(_ peer expr ...)
(syntax/loc stx (turn-sync! this-turn peer (lambda (_reply) expr ...)))]))
(define-for-syntax (with-valid-this-target orig-stx result-stx)
;; Invoke this-target transformer for its side effect: when it's
@ -233,32 +235,44 @@
(define-syntax (spawn stx)
(syntax-parse stx
[(_ name:<name> daemon:<daemon?>)
[(_ matches:<matches> condition:<when> name:<name> daemon:<daemon?>)
(raise-syntax-error #f "Need body in spawn")]
[(_ name:<name> daemon:<daemon?> setup-expr ...)
#'(turn-spawn! #:name name.N
#:daemon? daemon.D
this-turn
(lambda ()
(syntax-parameterize ([this-target illegal-use-of-this-target])
setup-expr ...)))]))
[(_ matches:<matches> condition:<when> name:<name> daemon:<daemon?> setup-expr ...)
#'(nested-matches
[[matches.pattern-pieces ... matches.discriminant] ...]
(when condition.E
(turn-spawn! #:name name.N
#:daemon? daemon.D
this-turn
(lambda ()
(syntax-parameterize ([this-target illegal-use-of-this-target])
setup-expr ...)))))]))
(define-syntax (spawn/link stx)
(syntax-parse stx
[(_ name-stx:<name> daemon:<daemon?> setup-expr ...)
#`(begin
(define name name-stx.N)
(define monitor (ref (entity/stop-on-retract #:name (list name 'monitor-in-parent))))
(define monitor-handle (turn-assert! this-turn monitor 'alive))
(turn-spawn! this-turn
#:name name
#:daemon? daemon.D
#:link
(entity/stop-on-retract #:name (list name 'monitor-in-child))
(lambda ()
(syntax-parameterize ([this-target illegal-use-of-this-target])
setup-expr ...))
(hasheq monitor-handle #t)))]))
[(_ matches:<matches> condition:<when> name-stx:<name> daemon:<daemon?> setup-expr ...)
#`(nested-matches
[[matches.pattern-pieces ... matches.discriminant] ...]
(when condition.E
(define name name-stx.N)
(define monitor (ref (entity/stop-on-retract #:name (list name 'monitor-in-parent))))
(define monitor-handle (turn-assert! this-turn monitor 'alive))
(turn-spawn! this-turn
#:name name
#:daemon? daemon.D
#:link
(entity/stop-on-retract #:name (list name 'monitor-in-child))
(lambda ()
(syntax-parameterize ([this-target illegal-use-of-this-target])
setup-expr ...))
(hasheq monitor-handle #t))))]))
(define-syntax nested-matches
(syntax-rules ()
[(_ [] body ...)
(begin body ...)]
[(_ [[p ... e] more ...] body ...)
(match e [p ... (nested-matches [more ...] body ...)] [_ (void)])]))
(define-syntax-rule (begin/dataflow expr ...)
(turn-dataflow! this-turn (lambda () expr ...)))
@ -364,12 +378,12 @@
(define-syntax during/spawn
(lambda (stx)
(syntax-parse stx
[(_ pat name-stx:<name> daemon:<daemon?> expr ...)
[(_ pat expr ...)
(quasisyntax/loc stx
(assert (Observe (:pattern pat)
(ref (during* (lambda (bindings)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
(spawn/link #:name name-stx.N #:daemon? daemon.D expr ...)))))))])))
(spawn/link expr ...)))))))])))
(define (during* f #:name [name '?])
(define assertion-map (make-hash))

Loading…
Cancel
Save