From 5d368fed9560cdd9c12acba4b695500842787ec0 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jan 2023 16:21:26 +0100 Subject: [PATCH] First experimental noise relay --- Makefile | 2 +- syndicate-noise/info.rkt | 6 + .../syndicate/distributed/noise.rkt | 159 ++++++++++++++++++ syndicate/relay.rkt | 31 ++-- 4 files changed, 186 insertions(+), 12 deletions(-) create mode 100644 syndicate-noise/info.rkt create mode 100644 syndicate-noise/syndicate/distributed/noise.rkt diff --git a/Makefile b/Makefile index 4098eb9..fedd011 100644 --- a/Makefile +++ b/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 diff --git a/syndicate-noise/info.rkt b/syndicate-noise/info.rkt new file mode 100644 index 0000000..b9fe762 --- /dev/null +++ b/syndicate-noise/info.rkt @@ -0,0 +1,6 @@ +#lang setup/infotab +;;; SPDX-License-Identifier: LGPL-3.0-or-later +;;; SPDX-FileCopyrightText: Copyright © 2023 Tony Garnock-Jones + +(define collection 'multi) +(define deps '("base" "syndicate" "preserves" "noise-protocol")) diff --git a/syndicate-noise/syndicate/distributed/noise.rkt b/syndicate-noise/syndicate/distributed/noise.rkt new file mode 100644 index 0000000..f888334 --- /dev/null +++ b/syndicate-noise/syndicate/distributed/noise.rkt @@ -0,0 +1,159 @@ +#lang syndicate +;;; SPDX-License-Identifier: LGPL-3.0-or-later +;;; SPDX-FileCopyrightText: Copyright © 2023 Tony Garnock-Jones + +(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!!!!!")))))) diff --git a/syndicate/relay.rkt b/syndicate/relay.rkt index 39bbe85..21695a1 100644 --- a/syndicate/relay.rkt +++ b/syndicate/relay.rkt @@ -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)