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

94
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,59 +24,32 @@
(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) (action (assertion)
(flush-output o)) (match (parse-Resolve assertion)
#:setup-inputs (action (tr) [(? eof-object?) (void)]
[(Resolve unvalidated-sturdyref observer)
(on-stop (close-input-port i) (at ds
(close-output-port o)) (during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
(define sturdyref (validate unvalidated-sturdyref key))
(linked-thread (define attenuation
#:name (cons 'input-thread name-base) (append-map Attenuation-value
#:custodian connection-custodian (reverse (SturdyRef-caveatChain sturdyref))))
this-turn (define attenuated-target
(ref (entity #:name (cons 'socket-monitor name-base) (apply attenuate-entity-ref target attenuation))
#:retract (action (_handle) (stop-current-facet)))) (at observer (assert (embedded attenuated-target)))))])))))
(lambda () ((run-relay #:name conn
(let loop () #:packet-writer (action (bs) (send-data this-turn conn bs))
(define bs (read-bytes-avail i)) #:setup-inputs
(when (bytes? bs) (action (tr)
(accept-bytes tr bs) (accept-connection this-turn conn
(loop)))))) #:on-data (action (bs) (accept-bytes tr bs))))
#:initial-ref #:initial-ref
(action () (action () gatekeeper))
(ref (during* #:name (cons 'gatekeeper name-base) this-turn))))))
(action (assertion)
(match (parse-Resolve assertion)
[(? eof-object?) (void)]
[(Resolve unvalidated-sturdyref observer)
(at ds
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
(define sturdyref (validate unvalidated-sturdyref key))
(define attenuation
(append-map Attenuation-value (reverse (SturdyRef-caveatChain sturdyref))))
(define attenuated-target
(apply attenuate-entity-ref target attenuation))
(at observer (assert (embedded attenuated-target)))))]))))))))
(spawn
#:name 'tcp-server
(linked-thread
#:name 'tcp-server
this-turn
(ref (entity #:name 'listen-monitor #:retract (action (_handle) (stop-current-facet))))
(lambda ()
(define listener (tcp-listen 5999 512 #t "0.0.0.0"))
(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)))))))

79
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,18 +77,16 @@
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(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 #""
#"" packet-writer
packet-writer (make-hash)
(make-hash) (make-hash)
(make-hash) (make-membrane)
(make-membrane) (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,32 +293,28 @@
(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]) (action ()
(turn-spawn! #:name name (define tr (make-tunnel-relay this-turn name packet-writer))
turn (setup-inputs this-turn tr)
(action () (when initial-ref (rewrite-ref-out tr
(define tr (make-tunnel-relay this-turn name packet-writer)) (if (procedure? initial-ref)
(setup-inputs this-turn tr) (initial-ref this-turn)
(when initial-ref initial-ref)
(rewrite-ref-out tr #f
(if (procedure? initial-ref) (lambda (_ws) (void))))
(initial-ref this-turn) (when then
initial-ref) (turn-assert! this-turn
#f then
(lambda (_ws) (void)))) (and initial-oid
(when then (embedded
(turn-assert! this-turn (rewrite-ref-in this-turn
then tr
(and initial-oid (sturdy:WireRef-mine
(embedded (sturdy:Oid initial-oid))
(rewrite-ref-in this-turn (lambda (_ws) (void)))))))))
tr
(sturdy:WireRef-mine
(sturdy:Oid initial-oid))
(lambda (_ws) (void))))))))))