First experimental noise relay
This commit is contained in:
parent
59f133a62f
commit
5d368fed95
2
Makefile
2
Makefile
|
@ -1,6 +1,6 @@
|
||||||
__ignored__ := $(shell ./setup.sh)
|
__ignored__ := $(shell ./setup.sh)
|
||||||
|
|
||||||
PACKAGES=syndicate syndicate-examples syndicate-msd
|
PACKAGES=syndicate syndicate-examples syndicate-msd syndicate-noise
|
||||||
COLLECTS=syndicate syndicate-examples
|
COLLECTS=syndicate syndicate-examples
|
||||||
|
|
||||||
all: setup
|
all: setup
|
||||||
|
|
|
@ -0,0 +1,6 @@
|
||||||
|
#lang setup/infotab
|
||||||
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
|
;;; SPDX-FileCopyrightText: Copyright © 2023 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
|
(define collection 'multi)
|
||||||
|
(define deps '("base" "syndicate" "preserves" "noise-protocol"))
|
|
@ -0,0 +1,159 @@
|
||||||
|
#lang syndicate
|
||||||
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||||
|
;;; SPDX-FileCopyrightText: Copyright © 2023 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||||
|
|
||||||
|
(provide noise-initiator
|
||||||
|
noise-responder)
|
||||||
|
|
||||||
|
(require syndicate/relay)
|
||||||
|
(require syndicate/schemas/noise)
|
||||||
|
(require noise-protocol)
|
||||||
|
|
||||||
|
(define-logger syndicate/distributed/noise)
|
||||||
|
|
||||||
|
(define (css->procedures css)
|
||||||
|
(match-define (list S R) css)
|
||||||
|
(values (lambda (bs) (S 'encrypt #"" bs))
|
||||||
|
(lambda (bs) (R 'decrypt #"" bs))))
|
||||||
|
|
||||||
|
(define (extract-packets m)
|
||||||
|
(match (parse-Packet! m)
|
||||||
|
[(Packet-complete bs) (list bs)]
|
||||||
|
[(Packet-fragmented bss) bss]))
|
||||||
|
|
||||||
|
(define PACKET-LIMIT (- 65535 16)) ;; 16 bytes for authentication tag
|
||||||
|
|
||||||
|
(define (chunk-bytes bs chunk-size)
|
||||||
|
(define len (bytes-length bs))
|
||||||
|
(for/list [(i (in-range 0 len chunk-size))]
|
||||||
|
(subbytes bs i (min (+ i chunk-size) len))))
|
||||||
|
|
||||||
|
(define (fragment bs [f values])
|
||||||
|
(if (> (bytes-length bs) PACKET-LIMIT)
|
||||||
|
(Packet-fragmented (map f (chunk-bytes bs PACKET-LIMIT)))
|
||||||
|
(Packet-complete (f bs))))
|
||||||
|
|
||||||
|
(define (noise-initiator #:service-selector service-selector
|
||||||
|
#:remote-static-pk remote-static-pk
|
||||||
|
#:acceptor-ref acceptor-ref
|
||||||
|
#:import import-handler
|
||||||
|
#:preshared-keys [psks #f]
|
||||||
|
#:pattern [pattern #f])
|
||||||
|
(noise* #:role 'initiator
|
||||||
|
#:service-selector service-selector
|
||||||
|
#:remote-static-pk remote-static-pk
|
||||||
|
#:acceptor-ref acceptor-ref
|
||||||
|
#:import import-handler
|
||||||
|
#:preshared-keys psks
|
||||||
|
#:pattern pattern))
|
||||||
|
|
||||||
|
(define (noise-responder #:service-selector service-selector
|
||||||
|
#:static-keypair static-keypair
|
||||||
|
#:export initial-ref
|
||||||
|
#:preshared-keys [psks #f]
|
||||||
|
#:pattern [pattern #f])
|
||||||
|
(noise* #:role 'responder
|
||||||
|
#:service-selector service-selector
|
||||||
|
#:static-keypair static-keypair
|
||||||
|
#:export initial-ref
|
||||||
|
#:preshared-keys psks
|
||||||
|
#:pattern pattern))
|
||||||
|
|
||||||
|
(define (noise* #:role role
|
||||||
|
#:service-selector service-selector
|
||||||
|
#:static-keypair [static-keypair #f]
|
||||||
|
#:remote-static-pk [remote-static-pk #f]
|
||||||
|
#:acceptor-ref [acceptor-ref #f]
|
||||||
|
#:export [initial-ref #f]
|
||||||
|
#:import [import-handler #f]
|
||||||
|
#:preshared-keys [psks #f]
|
||||||
|
#:pattern [pattern #f])
|
||||||
|
(define H (Noise-*-25519_ChaChaPoly_BLAKE2s
|
||||||
|
(or pattern "NK")
|
||||||
|
#:role role
|
||||||
|
#:prologue (encode/canonicalization service-selector)
|
||||||
|
#:static-keypair static-keypair
|
||||||
|
#:remote-static-pk remote-static-pk
|
||||||
|
#:preshared-keys psks))
|
||||||
|
|
||||||
|
(define encrypt! #f)
|
||||||
|
(define decrypt! #f)
|
||||||
|
(define relay #f)
|
||||||
|
(define peer-session #f)
|
||||||
|
(define buffered-inputs-rev '())
|
||||||
|
|
||||||
|
(define (start-relay css)
|
||||||
|
(set!-values (encrypt! decrypt!) (css->procedures css))
|
||||||
|
(run-relay #:packet-writer (lambda (bs) (send! peer-session (fragment bs encrypt!)))
|
||||||
|
#:setup-inputs (lambda (tr)
|
||||||
|
(set! relay tr)
|
||||||
|
(for [(m (in-list (reverse buffered-inputs-rev)))]
|
||||||
|
(accept-bytes relay m))
|
||||||
|
(set! buffered-inputs-rev #f))
|
||||||
|
#:then (and import-handler (object [(embedded a) (import-handler a)]))
|
||||||
|
#:initial-oid (and import-handler 0)
|
||||||
|
#:initial-ref initial-ref))
|
||||||
|
|
||||||
|
(define (handshake-step)
|
||||||
|
(define-values (packet css) (H 'write-message #""))
|
||||||
|
(send! peer-session (Packet-complete packet))
|
||||||
|
(when css (start-relay css)))
|
||||||
|
|
||||||
|
(define (handle-message m)
|
||||||
|
(log-syndicate/distributed/noise-info "~v ~a got: ~v" service-selector role m)
|
||||||
|
(for [(p (in-list (extract-packets m)))]
|
||||||
|
(if relay
|
||||||
|
(accept-bytes relay (decrypt! p))
|
||||||
|
(let-values (((message css) (H 'read-message p)))
|
||||||
|
(set! buffered-inputs-rev (cons message buffered-inputs-rev))
|
||||||
|
(if css
|
||||||
|
(start-relay css)
|
||||||
|
(handshake-step))))))
|
||||||
|
|
||||||
|
(define (set-peer-session! session)
|
||||||
|
(set! peer-session session)
|
||||||
|
(when (eq? role 'initiator) (handshake-step)))
|
||||||
|
|
||||||
|
(match role
|
||||||
|
['initiator
|
||||||
|
(at acceptor-ref
|
||||||
|
(assert (Connect service-selector
|
||||||
|
(object #:name 'noise-initiator
|
||||||
|
[#:asserted (Accept responder-session)
|
||||||
|
(set-peer-session! responder-session)
|
||||||
|
#:retracted
|
||||||
|
(stop-current-facet)]
|
||||||
|
[#:message m (handle-message m)]))))]
|
||||||
|
['responder
|
||||||
|
(object #:name (list 'noise-acceptor initial-ref)
|
||||||
|
[(Connect (== service-selector) initiator-session)
|
||||||
|
(set-peer-session! initiator-session)
|
||||||
|
(at initiator-session
|
||||||
|
(assert (Accept (object #:name (list 'noise-responder initial-ref initiator-session)
|
||||||
|
[#:message m (handle-message m)]))))])]))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require libsodium)
|
||||||
|
(file-stream-buffer-mode (current-output-port) 'none)
|
||||||
|
|
||||||
|
(standard-actor-system (ds)
|
||||||
|
(spawn #:name 'test-main
|
||||||
|
(define server-keys (make-crypto-box-keypair))
|
||||||
|
|
||||||
|
(define acceptor
|
||||||
|
(noise-responder #:service-selector 'test-service
|
||||||
|
#:static-keypair server-keys
|
||||||
|
#:export (object [a
|
||||||
|
(printf "service+: ~v\n" a)
|
||||||
|
(on-stop (printf "service-: ~v\n" a))]
|
||||||
|
[#:message m
|
||||||
|
(printf "service!: ~v\n" m)
|
||||||
|
(stop-current-facet)])))
|
||||||
|
|
||||||
|
(noise-initiator #:service-selector 'test-service
|
||||||
|
#:remote-static-pk (crypto-box-keypair-pk server-keys)
|
||||||
|
#:acceptor-ref acceptor
|
||||||
|
#:import (lambda (r)
|
||||||
|
(on-stop (printf "BYEEEE\n"))
|
||||||
|
(at r (assert "HELLO!"))
|
||||||
|
(send! r "HIIIII!!!!!"))))))
|
|
@ -4,6 +4,8 @@
|
||||||
|
|
||||||
(provide make-tunnel-relay
|
(provide make-tunnel-relay
|
||||||
accept-bytes
|
accept-bytes
|
||||||
|
accept-packet
|
||||||
|
encode/canonicalization
|
||||||
run-relay)
|
run-relay)
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
@ -110,7 +112,7 @@
|
||||||
(when (positive? start-pos)
|
(when (positive? start-pos)
|
||||||
(set-tunnel-relay-read-buffer! tr (subbytes buffer start-pos)))]
|
(set-tunnel-relay-read-buffer! tr (subbytes buffer start-pos)))]
|
||||||
[packet
|
[packet
|
||||||
(handle-packet tr packet)
|
(accept-packet tr packet)
|
||||||
(read-more)]))))))
|
(read-more)]))))))
|
||||||
|
|
||||||
(define (lookup-local tr local-oid)
|
(define (lookup-local tr local-oid)
|
||||||
|
@ -144,9 +146,9 @@
|
||||||
attenuation
|
attenuation
|
||||||
(lambda () (apply attenuate-entity-ref r attenuation))))]))
|
(lambda () (apply attenuate-entity-ref r attenuation))))]))
|
||||||
|
|
||||||
(define (handle-packet tr packet)
|
(define (accept-packet tr packet)
|
||||||
(match (parse-Turn packet)
|
(match (parse-Turn packet)
|
||||||
[(? eof-object?) (error 'handle-packet "Invalid IO.Turn")]
|
[(? eof-object?) (error 'accept-packet "Invalid IO.Turn")]
|
||||||
[(Turn wire-turn)
|
[(Turn wire-turn)
|
||||||
(log-syndicate/relay-debug "--> ~a" (preserve->string packet))
|
(log-syndicate/relay-debug "--> ~a" (preserve->string packet))
|
||||||
(for [(ev (in-list wire-turn))]
|
(for [(ev (in-list wire-turn))]
|
||||||
|
@ -161,7 +163,7 @@
|
||||||
imported))]
|
imported))]
|
||||||
[(Event-Retract (Retract (Handle remote-handle)))
|
[(Event-Retract (Retract (Handle remote-handle)))
|
||||||
(define i (hash-ref (tunnel-relay-inbound-assertions tr) remote-handle #f))
|
(define i (hash-ref (tunnel-relay-inbound-assertions tr) remote-handle #f))
|
||||||
(when (not i) (error 'handle-packet "Peer retracted invalid handle ~a" remote-handle))
|
(when (not i) (error 'accept-packet "Peer retracted invalid handle ~a" remote-handle))
|
||||||
(hash-remove! (tunnel-relay-inbound-assertions tr) remote-handle)
|
(hash-remove! (tunnel-relay-inbound-assertions tr) remote-handle)
|
||||||
(for [(ws (in-list (inbound-imported i)))]
|
(for [(ws (in-list (inbound-imported i)))]
|
||||||
(drop (tunnel-relay-imported-references tr) ws))
|
(drop (tunnel-relay-imported-references tr) ws))
|
||||||
|
@ -169,7 +171,7 @@
|
||||||
[(Event-Message (Message (Assertion body)))
|
[(Event-Message (Message (Assertion body)))
|
||||||
(define-values (a imported) (rewrite-in tr body))
|
(define-values (a imported) (rewrite-in tr body))
|
||||||
(when (not (null? imported))
|
(when (not (null? imported))
|
||||||
(error 'handle-packet "Cannot receive transient reference"))
|
(error 'accept-packet "Cannot receive transient reference"))
|
||||||
(turn-message! this-turn r a)]
|
(turn-message! this-turn r a)]
|
||||||
[(Event-Sync (Sync peer))
|
[(Event-Sync (Sync peer))
|
||||||
(define imported '())
|
(define imported '())
|
||||||
|
@ -193,11 +195,7 @@
|
||||||
(log-syndicate/relay-debug "<-- ~a"
|
(log-syndicate/relay-debug "<-- ~a"
|
||||||
(preserve->string (->preserve pending)))
|
(preserve->string (->preserve pending)))
|
||||||
(parse-Turn! (->preserve pending))
|
(parse-Turn! (->preserve pending))
|
||||||
((tunnel-relay-packet-writer tr)
|
((tunnel-relay-packet-writer tr) pending))))))
|
||||||
(preserve->bytes (->preserve pending)
|
|
||||||
#:canonicalizing? #t
|
|
||||||
#:write-annotations? #f
|
|
||||||
#:encode-embedded ->preserve)))))))
|
|
||||||
(set-tunnel-relay-pending-turn-rev! tr (cons (TurnEvent (Oid oid) event)
|
(set-tunnel-relay-pending-turn-rev! tr (cons (TurnEvent (Oid oid) event)
|
||||||
(tunnel-relay-pending-turn-rev tr))))
|
(tunnel-relay-pending-turn-rev tr))))
|
||||||
|
|
||||||
|
@ -292,13 +290,24 @@
|
||||||
(lambda (peer-k)
|
(lambda (peer-k)
|
||||||
(turn-sync! this-turn peer peer-k))))
|
(turn-sync! this-turn peer peer-k))))
|
||||||
|
|
||||||
|
(define (encode/canonicalization v)
|
||||||
|
(preserve->bytes (->preserve v)
|
||||||
|
#:canonicalizing? #t
|
||||||
|
#:write-annotations? #f
|
||||||
|
#:encode-embedded ->preserve))
|
||||||
|
|
||||||
(define (run-relay #:packet-writer packet-writer
|
(define (run-relay #:packet-writer packet-writer
|
||||||
|
#:auto-encode? [auto-encode? #t]
|
||||||
#: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])
|
||||||
(define tr (make-tunnel-relay name packet-writer))
|
(define tr (make-tunnel-relay name
|
||||||
|
(if auto-encode?
|
||||||
|
(lambda (pending)
|
||||||
|
(packet-writer (encode/canonicalization pending)))
|
||||||
|
packet-writer)))
|
||||||
(setup-inputs tr)
|
(setup-inputs tr)
|
||||||
(when initial-ref (rewrite-ref-out tr
|
(when initial-ref (rewrite-ref-out tr
|
||||||
(if (procedure? initial-ref)
|
(if (procedure? initial-ref)
|
||||||
|
|
Loading…
Reference in New Issue