2023-01-19 15:21:26 +00:00
|
|
|
#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
|
|
|
|
#:import import-handler
|
|
|
|
#:preshared-keys psks
|
2023-01-19 15:30:30 +00:00
|
|
|
#:pattern pattern
|
|
|
|
(lambda (set-peer-session! handle-message)
|
|
|
|
(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)])))))))
|
2023-01-19 15:21:26 +00:00
|
|
|
|
|
|
|
(define (noise-responder #:service-selector service-selector
|
|
|
|
#:static-keypair static-keypair
|
|
|
|
#:export initial-ref
|
2023-01-19 15:30:30 +00:00
|
|
|
#:initiator-session initiator-session
|
2023-01-19 15:21:26 +00:00
|
|
|
#:preshared-keys [psks #f]
|
|
|
|
#:pattern [pattern #f])
|
|
|
|
(noise* #:role 'responder
|
|
|
|
#:service-selector service-selector
|
|
|
|
#:static-keypair static-keypair
|
|
|
|
#:export initial-ref
|
|
|
|
#:preshared-keys psks
|
2023-01-19 15:30:30 +00:00
|
|
|
#:pattern pattern
|
|
|
|
(lambda (set-peer-session! handle-message)
|
|
|
|
(set-peer-session! initiator-session)
|
|
|
|
(at initiator-session
|
|
|
|
(assert (Accept (object #:name (list 'noise-responder initial-ref initiator-session)
|
|
|
|
[#:message m (handle-message m)])))))))
|
2023-01-19 15:21:26 +00:00
|
|
|
|
|
|
|
(define (noise* #:role role
|
|
|
|
#:service-selector service-selector
|
|
|
|
#:static-keypair [static-keypair #f]
|
|
|
|
#:remote-static-pk [remote-static-pk #f]
|
|
|
|
#:export [initial-ref #f]
|
|
|
|
#:import [import-handler #f]
|
|
|
|
#:preshared-keys [psks #f]
|
2023-01-19 15:30:30 +00:00
|
|
|
#:pattern [pattern #f]
|
|
|
|
f)
|
2023-01-19 15:21:26 +00:00
|
|
|
(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)))
|
|
|
|
|
2023-01-19 15:30:30 +00:00
|
|
|
(f set-peer-session! handle-message))
|
2023-01-19 15:21:26 +00:00
|
|
|
|
|
|
|
(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))
|
|
|
|
|
2023-01-19 15:30:30 +00:00
|
|
|
(define service-object
|
|
|
|
(object [a
|
|
|
|
(printf "service+: ~v\n" a)
|
|
|
|
(on-stop (printf "service-: ~v\n" a))]
|
|
|
|
[#:message m
|
|
|
|
(printf "service!: ~v\n" m)
|
|
|
|
(stop-current-facet)]))
|
|
|
|
|
|
|
|
(at ds
|
|
|
|
(during (Connect 'test-service $initiator-session)
|
|
|
|
(noise-responder #:service-selector 'test-service
|
|
|
|
#:static-keypair server-keys
|
|
|
|
#:initiator-session initiator-session
|
|
|
|
#:export service-object)))
|
2023-01-19 15:21:26 +00:00
|
|
|
|
|
|
|
(noise-initiator #:service-selector 'test-service
|
|
|
|
#:remote-static-pk (crypto-box-keypair-pk server-keys)
|
2023-01-19 15:30:30 +00:00
|
|
|
#:acceptor-ref ds
|
2023-01-19 15:21:26 +00:00
|
|
|
#:import (lambda (r)
|
|
|
|
(on-stop (printf "BYEEEE\n"))
|
|
|
|
(at r (assert "HELLO!"))
|
|
|
|
(send! r "HIIIII!!!!!"))))))
|