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)
|
||||
|
||||
PACKAGES=syndicate syndicate-examples syndicate-msd
|
||||
PACKAGES=syndicate syndicate-examples syndicate-msd syndicate-noise
|
||||
COLLECTS=syndicate syndicate-examples
|
||||
|
||||
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
|
||||
accept-bytes
|
||||
accept-packet
|
||||
encode/canonicalization
|
||||
run-relay)
|
||||
|
||||
(require racket/match)
|
||||
|
@ -110,7 +112,7 @@
|
|||
(when (positive? start-pos)
|
||||
(set-tunnel-relay-read-buffer! tr (subbytes buffer start-pos)))]
|
||||
[packet
|
||||
(handle-packet tr packet)
|
||||
(accept-packet tr packet)
|
||||
(read-more)]))))))
|
||||
|
||||
(define (lookup-local tr local-oid)
|
||||
|
@ -144,9 +146,9 @@
|
|||
attenuation
|
||||
(lambda () (apply attenuate-entity-ref r attenuation))))]))
|
||||
|
||||
(define (handle-packet tr packet)
|
||||
(define (accept-packet tr packet)
|
||||
(match (parse-Turn packet)
|
||||
[(? eof-object?) (error 'handle-packet "Invalid IO.Turn")]
|
||||
[(? eof-object?) (error 'accept-packet "Invalid IO.Turn")]
|
||||
[(Turn wire-turn)
|
||||
(log-syndicate/relay-debug "--> ~a" (preserve->string packet))
|
||||
(for [(ev (in-list wire-turn))]
|
||||
|
@ -161,7 +163,7 @@
|
|||
imported))]
|
||||
[(Event-Retract (Retract (Handle remote-handle)))
|
||||
(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)
|
||||
(for [(ws (in-list (inbound-imported i)))]
|
||||
(drop (tunnel-relay-imported-references tr) ws))
|
||||
|
@ -169,7 +171,7 @@
|
|||
[(Event-Message (Message (Assertion body)))
|
||||
(define-values (a imported) (rewrite-in tr body))
|
||||
(when (not (null? imported))
|
||||
(error 'handle-packet "Cannot receive transient reference"))
|
||||
(error 'accept-packet "Cannot receive transient reference"))
|
||||
(turn-message! this-turn r a)]
|
||||
[(Event-Sync (Sync peer))
|
||||
(define imported '())
|
||||
|
@ -193,11 +195,7 @@
|
|||
(log-syndicate/relay-debug "<-- ~a"
|
||||
(preserve->string (->preserve pending)))
|
||||
(parse-Turn! (->preserve pending))
|
||||
((tunnel-relay-packet-writer tr)
|
||||
(preserve->bytes (->preserve pending)
|
||||
#:canonicalizing? #t
|
||||
#:write-annotations? #f
|
||||
#:encode-embedded ->preserve)))))))
|
||||
((tunnel-relay-packet-writer tr) pending))))))
|
||||
(set-tunnel-relay-pending-turn-rev! tr (cons (TurnEvent (Oid oid) event)
|
||||
(tunnel-relay-pending-turn-rev tr))))
|
||||
|
||||
|
@ -292,13 +290,24 @@
|
|||
(lambda (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
|
||||
#:auto-encode? [auto-encode? #t]
|
||||
#:setup-inputs setup-inputs
|
||||
#:then [then #f]
|
||||
#:name [name (gensym 'relay)]
|
||||
#:initial-oid [initial-oid #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)
|
||||
(when initial-ref (rewrite-ref-out tr
|
||||
(if (procedure? initial-ref)
|
||||
|
|
Loading…
Reference in New Issue