syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Use tcp driver in tcp-server

This commit is contained in:
Tony Garnock-Jones 2021-06-10 10:53:30 +02:00
parent 45e8c29976
commit 9aa33210b0
2 changed files with 67 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
syndicate/distributed/tcp-server.rkt
View File

@ -4,7 +4,6 @@
(require (only-in sha bytes->hex-string)) (require (only-in sha bytes->hex-string))
(require racket/tcp)
(require (only-in racket/list append-map)) (require (only-in racket/list append-map))
(require syndicate/relay) (require syndicate/relay)
@ -12,13 +11,7 @@
(require syndicate/sturdy) (require syndicate/sturdy)
(require syndicate/schemas/gen/gatekeeper) (require syndicate/schemas/gen/gatekeeper)
(require syndicate/sturdy) (require syndicate/sturdy)
(require syndicate/driver-support) (require syndicate/drivers/tcp)
(define (read-bytes-avail input-port #:limit [limit 65536])
(define buffer (make-bytes limit))
(match (read-bytes-avail! buffer input-port)
[(? number? count) (subbytes buffer 0 count)]
[other other]))
(module+ main (module+ main
(actor-system/dataspace (ds) (actor-system/dataspace (ds)
@ -31,35 +24,13 @@
(newline) (newline)
(displayln (bytes->hex-string (sturdy-encode (->preserve root-cap)))) (displayln (bytes->hex-string (sturdy-encode (->preserve root-cap))))
(define spawn-connection (spawn-tcp-driver this-turn ds)
(action (connection-custodian i o) (spawn #:name 'tcp-server
(define name-base (call-with-values (lambda () (tcp-addresses i #t)) list)) (at ds
(spawn-relay (during/spawn (Connection $conn (TcpInbound "0.0.0.0" 5999))
this-turn (define gatekeeper
#:name name-base (ref
#:packet-writer (lambda (bs) (during* #:name (list conn 'gatekeeper)
(write-bytes bs o)
(flush-output o))
#:setup-inputs (action (tr)
(on-stop (close-input-port i)
(close-output-port o))
(linked-thread
#:name (cons 'input-thread name-base)
#:custodian connection-custodian
this-turn
(ref (entity #:name (cons 'socket-monitor name-base)
#:retract (action (_handle) (stop-current-facet))))
(lambda ()
(let loop ()
(define bs (read-bytes-avail i))
(when (bytes? bs)
(accept-bytes tr bs)
(loop))))))
#:initial-ref
(action ()
(ref (during* #:name (cons 'gatekeeper name-base)
(action (assertion) (action (assertion)
(match (parse-Resolve assertion) (match (parse-Resolve assertion)
[(? eof-object?) (void)] [(? eof-object?) (void)]
@ -68,22 +39,17 @@
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target) (during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
(define sturdyref (validate unvalidated-sturdyref key)) (define sturdyref (validate unvalidated-sturdyref key))
(define attenuation (define attenuation
(append-map Attenuation-value (reverse (SturdyRef-caveatChain sturdyref)))) (append-map Attenuation-value
(reverse (SturdyRef-caveatChain sturdyref))))
(define attenuated-target (define attenuated-target
(apply attenuate-entity-ref target attenuation)) (apply attenuate-entity-ref target attenuation))
(at observer (assert (embedded attenuated-target)))))])))))))) (at observer (assert (embedded attenuated-target)))))])))))
((run-relay #:name conn
(spawn #:packet-writer (action (bs) (send-data this-turn conn bs))
#:name 'tcp-server #:setup-inputs
(linked-thread (action (tr)
#:name 'tcp-server (accept-connection this-turn conn
this-turn #:on-data (action (bs) (accept-bytes tr bs))))
(ref (entity #:name 'listen-monitor #:retract (action (_handle) (stop-current-facet)))) #:initial-ref
(lambda () (action () gatekeeper))
(define listener (tcp-listen 5999 512 #t "0.0.0.0")) this-turn))))))
(let loop ()
(define connection-custodian (make-custodian))
(define-values (i o) (parameterize ((current-custodian connection-custodian))
(tcp-accept listener)))
(turn-freshen this-turn (action () (spawn-connection this-turn connection-custodian i o)))
(loop)))))))

15
syndicate/relay.rkt
View File

@ -4,7 +4,7 @@
(provide make-tunnel-relay (provide make-tunnel-relay
accept-bytes accept-bytes
spawn-relay) run-relay)
(require racket/match) (require racket/match)
(require preserves) (require preserves)
@ -77,7 +77,6 @@
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(define (make-tunnel-relay turn name packet-writer) (define (make-tunnel-relay turn name packet-writer)
(define tr
(tunnel-relay (turn-active-facet turn) (tunnel-relay (turn-active-facet turn)
name name
#"" #""
@ -88,7 +87,6 @@
(make-membrane) (make-membrane)
0 0
'())) '()))
tr)
(define accept-bytes (define accept-bytes
(lambda (tr bs) (lambda (tr bs)
@ -198,6 +196,7 @@
(log-info "OUT (raw): ~v" (->preserve pending)) (log-info "OUT (raw): ~v" (->preserve pending))
(parse-Turn! (->preserve pending)) (parse-Turn! (->preserve pending))
((tunnel-relay-packet-writer tr) ((tunnel-relay-packet-writer tr)
this-turn
(preserve->bytes (->preserve pending) (preserve->bytes (->preserve pending)
#:canonicalizing? #t #:canonicalizing? #t
#:write-annotations? #f #:write-annotations? #f
@ -294,20 +293,16 @@
(action (peer-k) (action (peer-k)
(turn-sync! this-turn peer peer-k)))) (turn-sync! this-turn peer peer-k))))
(define (spawn-relay turn (define (run-relay #:packet-writer packet-writer
#:packet-writer packet-writer
#:setup-inputs setup-inputs #:setup-inputs setup-inputs
#:then [then #f] #:then [then #f]
#:name [name (gensym 'relay)] #:name [name (gensym 'relay)]
#:initial-oid [initial-oid #f] #:initial-oid [initial-oid #f]
#:initial-ref [initial-ref #f]) #:initial-ref [initial-ref #f])
(turn-spawn! #:name name
turn
(action () (action ()
(define tr (make-tunnel-relay this-turn name packet-writer)) (define tr (make-tunnel-relay this-turn name packet-writer))
(setup-inputs this-turn tr) (setup-inputs this-turn tr)
(when initial-ref (when initial-ref (rewrite-ref-out tr
(rewrite-ref-out tr
(if (procedure? initial-ref) (if (procedure? initial-ref)
(initial-ref this-turn) (initial-ref this-turn)
initial-ref) initial-ref)
@ -322,4 +317,4 @@
tr tr
(sturdy:WireRef-mine (sturdy:WireRef-mine
(sturdy:Oid initial-oid)) (sturdy:Oid initial-oid))
(lambda (_ws) (void)))))))))) (lambda (_ws) (void)))))))))