syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

First experimental noise relay

This commit is contained in:
Tony Garnock-Jones 2023-01-19 16:21:26 +01:00
parent 59f133a62f
commit 5d368fed95
4 changed files with 186 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -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

6
syndicate-noise/info.rkt Normal file
View File

@ -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"))

159
syndicate-noise/syndicate/distributed/noise.rkt Normal file
View File

@ -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!!!!!"))))))

31
syndicate/relay.rkt
View File

@ -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)