86 lines
3.6 KiB
Racket
86 lines
3.6 KiB
Racket
#lang syndicate
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(require (only-in sha bytes->hex-string))
|
|
|
|
(require racket/tcp)
|
|
(require (only-in racket/list append-map))
|
|
|
|
(require syndicate/relay)
|
|
(require syndicate/sturdy)
|
|
(require syndicate/schemas/gen/gatekeeper)
|
|
(require syndicate/sturdy)
|
|
(require syndicate/driver-support)
|
|
|
|
(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
|
|
(actor-system/dataspace (ds)
|
|
(define ds-oid "syndicate")
|
|
(define ds-key (make-bytes KEY_LENGTH))
|
|
(at ds (assert (Bind ds-oid ds-key ds)))
|
|
|
|
(define root-cap (mint ds-oid ds-key))
|
|
(write-preserve/text (->preserve root-cap) #:indent 4 #:commas? #f)
|
|
(newline)
|
|
(displayln (bytes->hex-string (sturdy-encode (->preserve root-cap))))
|
|
|
|
(define spawn-connection
|
|
(action (connection-custodian i o)
|
|
(define name-base (call-with-values (lambda () (tcp-addresses i #t)) list))
|
|
(spawn-relay
|
|
this-turn
|
|
#:name name-base
|
|
#:packet-writer (lambda (bs) (write-bytes bs 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
|
|
(ref (during* #:name (cons 'gatekeeper name-base)
|
|
(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 values (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)))))))
|