2021-06-08 07:33:56 +00:00
|
|
|
#lang syndicate
|
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
2023-01-16 14:57:29 +00:00
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021-2023 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
2021-06-08 07:33:56 +00:00
|
|
|
|
|
|
|
(require (only-in sha bytes->hex-string))
|
|
|
|
|
|
|
|
(require (only-in racket/list append-map))
|
|
|
|
|
|
|
|
(require syndicate/relay)
|
2021-06-09 13:06:58 +00:00
|
|
|
(require syndicate/rewrite)
|
2021-06-08 07:33:56 +00:00
|
|
|
(require syndicate/sturdy)
|
2021-07-01 07:40:52 +00:00
|
|
|
(require syndicate/schemas/gatekeeper)
|
2021-06-08 07:33:56 +00:00
|
|
|
(require syndicate/sturdy)
|
2021-06-10 08:53:30 +00:00
|
|
|
(require syndicate/drivers/tcp)
|
2021-06-08 07:33:56 +00:00
|
|
|
|
|
|
|
(module+ main
|
2021-06-17 12:57:06 +00:00
|
|
|
(standard-actor-system (ds)
|
2021-06-08 07:33:56 +00:00
|
|
|
(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))
|
2021-06-08 13:38:24 +00:00
|
|
|
(write-preserve/text (->preserve root-cap) #:indent 4 #:commas? #f)
|
2021-06-08 07:33:56 +00:00
|
|
|
(newline)
|
2021-06-08 13:38:24 +00:00
|
|
|
(displayln (bytes->hex-string (sturdy-encode (->preserve root-cap))))
|
2021-06-08 07:33:56 +00:00
|
|
|
|
2021-07-27 14:01:12 +00:00
|
|
|
(define spec (TcpLocal "0.0.0.0" 8001))
|
2021-06-17 12:57:06 +00:00
|
|
|
(at ds
|
2021-06-18 11:48:12 +00:00
|
|
|
(stop-on (asserted (StreamListenerError spec _)))
|
2021-06-17 12:57:06 +00:00
|
|
|
(during/spawn (StreamConnection $source $sink spec)
|
|
|
|
#:name (list 'tcp-server source)
|
|
|
|
(run-relay #:packet-writer (lambda (bs) (send-data sink bs))
|
|
|
|
#:setup-inputs
|
|
|
|
(lambda (tr)
|
|
|
|
(handle-connection source sink
|
|
|
|
#:on-data (lambda (d _m) (accept-bytes tr d))))
|
|
|
|
#:initial-ref
|
|
|
|
(object #:name 'gatekeeper
|
|
|
|
[(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)))))]))))))
|