diff --git a/syndicate-ssh/aes-ctr.rkt b/syndicate-ssh/aes-ctr.rkt deleted file mode 100644 index 7aedeb0..0000000 --- a/syndicate-ssh/aes-ctr.rkt +++ /dev/null @@ -1,66 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones - -;;; Provide AES CTR mode, since OpenSSL's EVP support for AES CTR mode -;;; is still ifdef'd out. - -(provide start-aes-ctr - aes-ctr-process!) - -(require ffi/unsafe) -(require ffi/unsafe/define) -(require openssl/libcrypto) - -(define _AES_KEY-pointer _pointer) - -(define AES_BLOCK_SIZE 16) -(define sizeof-AES_KEY 244) ;; TODO: figure out a good way to get this - ;; from the header file or the library - ;; itself - -(define-ffi-definer define-crypto libcrypto - #:default-make-fail make-not-available) - -(define-crypto AES_set_encrypt_key (_fun _pointer _int _AES_KEY-pointer -> _int)) -;;(define-crypto AES_set_decrypt_key (_fun _pointer _int _AES_KEY-pointer -> _int)) - -(define-crypto AES_ctr128_encrypt - (_fun _pointer ;; in - _pointer ;; out - _long ;; length - _AES_KEY-pointer ;; key - _pointer ;; ivec, AES_BLOCK_SIZE bytes - _pointer ;; ecount_buf, AES_BLOCK_SIZE bytes - _pointer ;; int pointer, the "num" field of the ongoing state (??) - -> _void)) - -(struct aes-ctr-state (key ivec ecount num) #:transparent) - -(define (start-aes-ctr key initialization-vector) - (let ((key-buffer (malloc sizeof-AES_KEY)) - (ivec (make-bytes AES_BLOCK_SIZE)) - (ecount (make-bytes AES_BLOCK_SIZE)) - (num (make-bytes (ctype-sizeof _int)))) - (AES_set_encrypt_key key - (* 8 (bytes-length key)) ;; measured in bits - key-buffer) - (bytes-copy! ivec 0 initialization-vector 0 AES_BLOCK_SIZE) - (bytes-fill! ecount 0) - (bytes-fill! num 0) - (aes-ctr-state key-buffer - ivec - ecount - num))) - -(define (aes-ctr-process! state input-block) - (define block-length (bytes-length input-block)) - (define output-block (make-bytes block-length)) - (AES_ctr128_encrypt input-block - output-block - block-length - (aes-ctr-state-key state) - (aes-ctr-state-ivec state) - (aes-ctr-state-ecount state) - (aes-ctr-state-num state)) - output-block) diff --git a/syndicate-ssh/crypto.rkt b/syndicate-ssh/crypto.rkt new file mode 100644 index 0000000..c8f5a5d --- /dev/null +++ b/syndicate-ssh/crypto.rkt @@ -0,0 +1,9 @@ +#lang racket/base +;;; SPDX-License-Identifier: LGPL-3.0-or-later +;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones + +(provide (all-from-out crypto)) + +(require crypto) +(require crypto/all) +(use-all-factories!) diff --git a/syndicate-ssh/functional-queue.rkt b/syndicate-ssh/functional-queue.rkt deleted file mode 100644 index 0cddbde..0000000 --- a/syndicate-ssh/functional-queue.rkt +++ /dev/null @@ -1,77 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones - -(provide make-queue - queue? - enqueue - enqueue-all - dequeue - list->queue - queue->list - queue-length - queue-empty? - queue-append - queue-extract) - -(struct queue (head tail) #:transparent) - -(define (make-queue) - (queue '() '())) - -(define (enqueue q v) - (queue (queue-head q) - (cons v (queue-tail q)))) - -(define (enqueue-all q v) - (queue (queue-head q) - (append (reverse v) (queue-tail q)))) - -(define (shuffle q) - (if (null? (queue-head q)) - (queue (reverse (queue-tail q)) '()) - q)) - -(define (dequeue q) - (let ((q1 (shuffle q))) - (values (car (queue-head q1)) - (queue (cdr (queue-head q1)) (queue-tail q1))))) - -(define (list->queue xs) - (queue xs '())) - -(define (queue->list q) - (append (queue-head q) (reverse (queue-tail q)))) - -(define (queue-length q) - (+ (length (queue-head q)) - (length (queue-tail q)))) - -(define (queue-empty? q) - (and (null? (queue-head q)) - (null? (queue-tail q)))) - -(define (queue-append q1 q2) - (queue (append (queue-head q1) - (reverse (queue-tail q1)) - (queue-head q2)) - (queue-tail q2))) - -(define (queue-extract q predicate [default-value #f]) - (let search-head ((head (queue-head q)) - (rejected-head-rev '())) - (cond - ((null? head) (let search-tail ((tail (reverse (queue-tail q))) - (rejected-tail-rev '())) - (cond - ((null? tail) (values default-value q)) - ((predicate (car tail)) (values (car tail) - (queue (queue-head q) - (append (reverse (cdr tail)) - rejected-tail-rev)))) - (else (search-tail (cdr tail) (cons (car tail) rejected-tail-rev)))))) - ((predicate (car head)) (values (car head) - (queue (append (reverse rejected-head-rev) - (cdr head)) - (queue-tail q)))) - (else (search-head (cdr head) (cons (car head) rejected-head-rev)))))) diff --git a/syndicate-ssh/info.rkt b/syndicate-ssh/info.rkt index b88b3f0..822ed52 100644 --- a/syndicate-ssh/info.rkt +++ b/syndicate-ssh/info.rkt @@ -9,11 +9,12 @@ "base" "bitsyntax" - "syndicate" + "crypto" "preserves" + "syndicate" )) -;; (define build-deps '("rackunit-lib")) +(define build-deps '("rackunit-lib")) (define pre-install-collection "private/install.rkt") diff --git a/syndicate-ssh/marketplace-support.rkt b/syndicate-ssh/marketplace-support.rkt deleted file mode 100644 index 3692a5e..0000000 --- a/syndicate-ssh/marketplace-support.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2013-2021 Tony Garnock-Jones - -;;; Reexport racket-matrix module contents. - -(require marketplace/sugar) -(require marketplace/drivers/tcp) -(require marketplace/drivers/timer) -(require marketplace/drivers/event-relay) - -(provide (all-from-out marketplace/sugar)) -(provide (all-from-out marketplace/drivers/tcp)) -(provide (all-from-out marketplace/drivers/timer)) -(provide (all-from-out marketplace/drivers/event-relay)) diff --git a/syndicate-ssh/new-server.rkt b/syndicate-ssh/new-server.rkt index 25bd95b..0f9e2e7 100644 --- a/syndicate-ssh/new-server.rkt +++ b/syndicate-ssh/new-server.rkt @@ -1,12 +1,13 @@ -#lang racket/base +#lang syndicate ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones ;;; (Temporary) example client and server -(require racket/set) -(require racket/match) -(require racket/contract) +(require syndicate/drivers/timer) +(require syndicate/drivers/tcp) +(require syndicate/dataspace) + (require (only-in racket/port peek-bytes-avail!-evt)) (require "cook-port.rkt") (require "sandboxes.rkt") @@ -17,19 +18,16 @@ (require "ssh-channel.rkt") (require "ssh-message-types.rkt") (require "ssh-exceptions.rkt") -(require "marketplace-support.rkt") -(define (main) - (ground-vm (timer-driver) - (tcp-driver) - (tcp-spy) - (name-process 'ssh-tcp-listener (spawn listener)))) - -(define listener - (transition/no-state - (observe-publishers (tcp-channel ? (tcp-listener 2322) ?) - (match-conversation r - (on-presence (session-vm r)))))) +(module+ main + (actor-system/dataspace (ds) + (spawn-timer-driver ds) + (spawn-tcp-driver ds) + (spawn #:name 'ssh-tcp-listener + (at ds + (during/spawn (Connection $conn (TcpInbound "0.0.0.0" 2322)) + #:name (list 'ssh conn) + (session ds conn)))))) ;;--------------------------------------------------------------------------- @@ -44,242 +42,164 @@ "Invalid peer identification string ~v" peer-identification-string))) -(define (spy marker) - (define (dump what message) - (write `(,marker ,what ,message)) - (newline) - (flush-output) - (void)) - (list - (observe-publishers/everything (wild) - (match-interest-type i - (match-conversation c - (on-presence (dump 'arrived (role 'publisher c i))) - (on-absence (dump 'departed (role 'publisher c i))) - (on-message [message (dump 'message message)])))) - (observe-subscribers/everything (wild) - (match-interest-type i - (match-conversation c - (on-presence (dump 'arrived (role 'subscriber c i))) - (on-absence (dump 'departed (role 'subscriber c i))) - (on-message [message (dump 'feedback message)])))))) +(define (session ground-ds conn) + (define root-facet this-facet) -(define-syntax-rule (wait-as my-orientation topic action ...) - (let-fresh (endpoint-name) - (build-endpoint endpoint-name - (role my-orientation topic 'observer) - (match-state state - (on-presence (sequence-actions (transition state - (delete-endpoint endpoint-name) - action ...))))))) + (define update-input-handler + (accept-connection conn + #:initial-credit #f + #:on-data (lambda (input mode) (error 'session "Unexpected input")))) -(define (session-vm new-conversation) - (match-define (tcp-channel remote-addr local-addr _) new-conversation) - (define local-identification #"SSH-2.0-RacketSSH_0.0") + (define local-identification "SSH-2.0-RacketSSH_0.0") + (send-line conn local-identification) - (define (issue-identification-string) - (at-meta-level - (send-message (tcp-channel local-addr remote-addr - (bytes-append local-identification #"\r\n"))))) + (send-lines-credit conn 1 (LineMode-crlf)) + (update-input-handler + #:on-data (lambda (remote-identification _mode) + (check-remote-identification! remote-identification) - (define (read-handshake-and-become-reader) - (transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't! - (at-meta-level - (name-endpoint 'socket-reader - (subscriber (tcp-channel remote-addr local-addr ?) - (match-state state - (on-message - [(tcp-channel _ _ (? eof-object?)) - (transition state (quit))] - [(tcp-channel _ _ (? bytes? remote-identification)) - (begin - (check-remote-identification! remote-identification) - (sequence-actions (transition state) - ;; First, set the incoming mode to bytes. - (at-meta-level - (send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes)))) - ;; Then initialise the reader, switching to packet-reading mode. - (lambda (ignored-state) (ssh-reader new-conversation)) - ;; Finally, spawn the remaining processes and issue - ;; the initial credit to the reader. - (name-process 'ssh-writer - ;; TODO: canary: #:exit-signal? #t - (spawn (ssh-writer new-conversation))) - ;; Wait for the reader and writer get started, then tell - ;; the reader we are ready for a single packet and spawn - ;; the session manager. - (wait-as 'subscriber (inbound-packet (wild) (wild) (wild) (wild)) - (wait-as 'publisher (outbound-packet (wild)) - (send-message (inbound-credit 1)) - (name-process 'ssh-session - (spawn #:pid session-pid - ;; TODO: canary: #:exit-signal? #t - (ssh-session session-pid - local-identification - remote-identification - repl-boot - 'server)))))))]))))))) + (define session-vm + (actor-group [(on-stop + (stop-facet root-facet) + (log-info "Session VM for ~a closed" conn))] + (define conn-ds (dataspace #:name (gensym 'conn-ds))) - (define (exn->outbound-packet reason) - (outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason) - (string->bytes/utf-8 (exn-message reason)) - #""))) + (spawn/link #:name 'reader + (ssh-reader conn-ds conn update-input-handler)) + (spawn/link #:name 'writer + (ssh-writer conn-ds conn)) - (define (disconnect-message-required? reason) - (and (exn:fail:contract:protocol? reason) - (not (exn:fail:contract:protocol-originated-at-peer? reason)))) + ;; Wait for the reader and writer get started, then tell the reader + ;; we are ready for a single packet and spawn the session manager. + (react + (at conn-ds + (stop-when (asserted (Observe (:pattern (inbound-credit ,_)) _)) + (send! conn-ds (inbound-credit 1)) - (define (active-exception-handler reason) - ;; This is kind of gross: because the absence handler gets invoked - ;; several times in a row because of multiple flows intersecting - ;; this role, we have to be careful to make the transmission of - ;; the disconnection packet idempotent. - ;; TODO: this is likely no longer true now we're using exit-signals %%% - (define interesting? (disconnect-message-required? reason)) - (transition inert-exception-handler - (when interesting? (send-message (exn->outbound-packet reason))) - (yield state ;; gross - (transition state (at-meta-level (quit #f (and interesting? reason))))))) + (spawn/link + #:name 'session + (ssh-session conn-ds + ground-ds + local-identification + remote-identification + (lambda (user-name) + (error 'repl-boot "Would start session with ~a" user-name)) + 'server))))) - (define (inert-exception-handler reason) - inert-exception-handler) + (at conn-ds + (during $m + (on-start (log-info "++ ~v" m)) + (on-stop (log-info "-- ~v" m))) + (when (message $m) + (log-info ">> ~v" m))) - (spawn-vm #:debug-name (list 'ssh-session-vm new-conversation) - (event-relay 'ssh-event-relay) - (timer-relay 'ssh-timer-relay) - (spy 'SSH) + (at conn-ds + (when (asserted (protocol-error $reason-code $message _ $originated-at-peer?)) + (when (not originated-at-peer?) + (send! conn-ds + (outbound-packet (ssh-msg-disconnect reason-code + (string->bytes/utf-8 message) + #"")))) + (actor-system-shutdown! session-vm))))) - (issue-identification-string) - - ;; Expect identification string, then update (!) our inbound - ;; subscription handler to switch to packet mode. - (at-meta-level - (send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'lines))) - (send-feedback (tcp-channel remote-addr local-addr (tcp-credit 1)))) - - (name-process 'ssh-reader - ;; TODO: canary: #:exit-signal? #t - (spawn (read-handshake-and-become-reader))) - - ;; TODO: canary: - ;; (spawn #:child - ;; (transition active-exception-handler - ;; (role (topic-subscriber (exit-signal (wild) (wild))) - ;; #:state current-handler - ;; #:reason reason - ;; #:on-absence (current-handler reason)))) - )) + (void)))) ;;--------------------------------------------------------------------------- -(define (repl-boot user-name) - (list - (event-relay 'app-event-relay) - (spy 'APP) - (at-meta-level - (subscriber (channel-message (channel-stream-name #t (wild)) (wild)) - (match-conversation (channel-message (channel-stream-name _ cname) _) - (on-presence (name-process cname (spawn (repl-instance user-name cname))))))))) +;; ;; (repl-instance InputPort OutputPort InputPort OutputPort) +;; (struct repl-instance-state (c2s-in ;; used by thread to read input from relay +;; c2s-out ;; used by relay to feed input from remote to the thread +;; s2c-in ;; used by relay to feed output from thread to remote +;; s2c-out ;; used by thread to write output to relay +;; ) #:prefab) -;; (repl-instance InputPort OutputPort InputPort OutputPort) -(struct repl-instance-state (c2s-in ;; used by thread to read input from relay - c2s-out ;; used by relay to feed input from remote to the thread - s2c-in ;; used by relay to feed output from thread to remote - s2c-out ;; used by thread to write output to relay - ) #:prefab) - -(define (repl-instance user-name cname) - (define inbound-stream (channel-stream-name #t cname)) - (define outbound-stream (channel-stream-name #f cname)) - (define (ch-do action-ctor stream body) - (at-meta-level (action-ctor (channel-message stream body)))) - (define (handle-channel-message state body) - (match body - [(channel-stream-request #"pty-req" _) - (match-define (repl-instance-state old-in _ _ old-out) state) - (define-values (cooked-in cooked-out) (cook-io old-in old-out "> ")) - (transition (struct-copy repl-instance-state state - [c2s-in cooked-in] - [s2c-out cooked-out]) - (ch-do send-feedback inbound-stream (channel-stream-ok)))] - [(channel-stream-notify #"env" _) - ;; Don't care - (transition state)] - [(channel-stream-request #"shell" _) - (match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state) - (define buffer-size 1024) - (define dummy-buffer (make-bytes buffer-size)) - (define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out)))) - (transition state - (ch-do send-feedback inbound-stream (channel-stream-ok)) - (subscriber (cons (thread-dead-evt repl-thread) (wild)) - (on-message [_ (quit #f "REPL thread exited")])) - (subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild)) - ;; We're using peek-bytes-avail!-evt rather than - ;; read-bytes-avail!-evt because of potential overwriting - ;; of the buffer. The overwriting can happen when there's - ;; any latency between handling the event and the next - ;; firing of the event, since the peek-bytes-avail!-evt - ;; will overwrite its buffer next time it's synced on. - (match-state state - (on-message - [(cons _ (? eof-object?)) - (let () - (match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state) - (close-input-port c2s-in) - (close-output-port c2s-out) - (close-input-port s2c-in) - (close-output-port s2c-out) - (transition state (quit)))] - [(cons _ (? number? count)) - (transition state - (ch-do send-message outbound-stream (channel-stream-data - (read-bytes count s2c-in))))]))))] - [(or (channel-stream-data #"\4") ;; C-d a.k.a EOT - (channel-stream-eof)) - (let () - (close-output-port (repl-instance-state-c2s-out state)) - ;; ^ this signals the repl thread to exit. - ;; Now, wait for it to do so. - (transition state))] - [(channel-stream-data bs) - (write-bytes bs (repl-instance-state-c2s-out state)) - (flush-output (repl-instance-state-c2s-out state)) - (transition state - (ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))] - [m - (write `(channel inbound ,m)) (newline) - (transition state)])) - (match (channel-name-type cname) - [#"session" - (define-values (c2s-in c2s-out) (make-pipe)) - (define-values (s2c-in s2c-out) (make-pipe)) - (transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out) - (at-meta-level - (subscriber (channel-message inbound-stream (wild)) - (match-state state - (on-presence (transition state - (ch-do send-feedback inbound-stream (channel-stream-config - (default-packet-limit) - #"")) - (ch-do send-feedback inbound-stream (channel-stream-credit 1024)))) - (on-message - [(channel-message _ body) - (handle-channel-message state body)])))) - (at-meta-level - (publisher (channel-message outbound-stream (wild)) - (on-message [m (begin - (write `(channel outbound ,cname ,m)) (newline) - (void))]))))] - [type - (transition/no-state - (at-meta-level (send-message - (channel-message outbound-stream - (channel-stream-open-failure - SSH_OPEN_UNKNOWN_CHANNEL_TYPE - (bytes-append #"Unknown channel type " type))))))])) - -;;--------------------------------------------------------------------------- - -;; TODO: module+ -(main) +;; (define (repl-instance user-name cname) +;; (define inbound-stream (channel-stream-name #t cname)) +;; (define outbound-stream (channel-stream-name #f cname)) +;; (define (ch-do action-ctor stream body) +;; (at-meta-level (action-ctor (channel-message stream body)))) +;; (define (handle-channel-message state body) +;; (match body +;; [(channel-stream-request #"pty-req" _) +;; (match-define (repl-instance-state old-in _ _ old-out) state) +;; (define-values (cooked-in cooked-out) (cook-io old-in old-out "> ")) +;; (transition (struct-copy repl-instance-state state +;; [c2s-in cooked-in] +;; [s2c-out cooked-out]) +;; (ch-do send-feedback inbound-stream (channel-stream-ok)))] +;; [(channel-stream-notify #"env" _) +;; ;; Don't care +;; (transition state)] +;; [(channel-stream-request #"shell" _) +;; (match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state) +;; (define buffer-size 1024) +;; (define dummy-buffer (make-bytes buffer-size)) +;; (define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out)))) +;; (transition state +;; (ch-do send-feedback inbound-stream (channel-stream-ok)) +;; (subscriber (cons (thread-dead-evt repl-thread) (wild)) +;; (on-message [_ (quit #f "REPL thread exited")])) +;; (subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild)) +;; ;; We're using peek-bytes-avail!-evt rather than +;; ;; read-bytes-avail!-evt because of potential overwriting +;; ;; of the buffer. The overwriting can happen when there's +;; ;; any latency between handling the event and the next +;; ;; firing of the event, since the peek-bytes-avail!-evt +;; ;; will overwrite its buffer next time it's synced on. +;; (match-state state +;; (on-message +;; [(cons _ (? eof-object?)) +;; (let () +;; (match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state) +;; (close-input-port c2s-in) +;; (close-output-port c2s-out) +;; (close-input-port s2c-in) +;; (close-output-port s2c-out) +;; (transition state (quit)))] +;; [(cons _ (? number? count)) +;; (transition state +;; (ch-do send-message outbound-stream (channel-stream-data +;; (read-bytes count s2c-in))))]))))] +;; [(or (channel-stream-data #"\4") ;; C-d a.k.a EOT +;; (channel-stream-eof)) +;; (let () +;; (close-output-port (repl-instance-state-c2s-out state)) +;; ;; ^ this signals the repl thread to exit. +;; ;; Now, wait for it to do so. +;; (transition state))] +;; [(channel-stream-data bs) +;; (write-bytes bs (repl-instance-state-c2s-out state)) +;; (flush-output (repl-instance-state-c2s-out state)) +;; (transition state +;; (ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))] +;; [m +;; (write `(channel inbound ,m)) (newline) +;; (transition state)])) +;; (match (channel-name-type cname) +;; [#"session" +;; (define-values (c2s-in c2s-out) (make-pipe)) +;; (define-values (s2c-in s2c-out) (make-pipe)) +;; (transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out) +;; (at-meta-level +;; (subscriber (channel-message inbound-stream (wild)) +;; (match-state state +;; (on-presence (transition state +;; (ch-do send-feedback inbound-stream (channel-stream-config +;; (default-packet-limit) +;; #"")) +;; (ch-do send-feedback inbound-stream (channel-stream-credit 1024)))) +;; (on-message +;; [(channel-message _ body) +;; (handle-channel-message state body)])))) +;; (at-meta-level +;; (publisher (channel-message outbound-stream (wild)) +;; (on-message [m (begin +;; (write `(channel outbound ,cname ,m)) (newline) +;; (void))]))))] +;; [type +;; (transition/no-state +;; (at-meta-level (send-message +;; (channel-message outbound-stream +;; (channel-stream-open-failure +;; SSH_OPEN_UNKNOWN_CHANNEL_TYPE +;; (bytes-append #"Unknown channel type " type))))))])) diff --git a/syndicate-ssh/oakley-groups.rkt b/syndicate-ssh/oakley-groups.rkt index 89c061d..fb0f6c5 100644 --- a/syndicate-ssh/oakley-groups.rkt +++ b/syndicate-ssh/oakley-groups.rkt @@ -7,24 +7,24 @@ (provide dh:oakley-group-2 dh:oakley-group-14) -;;(require (planet vyzo/crypto)) -(require (planet vyzo/crypto/dh)) +(require "crypto.rkt") + (require (only-in net/base64 base64-decode)) (define dh:oakley-group-2 - (make-!dh - 1024 + (datum->pk-parameters (base64-decode #"MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE 3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta - iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC"))) + iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC") + 'DHParameter)) (define dh:oakley-group-14 - (make-!dh - 2048 + (datum->pk-parameters (base64-decode #"MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr +1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei - j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg=="))) + j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==") + 'DHParameter)) diff --git a/syndicate-ssh/ssh-exceptions.rkt b/syndicate-ssh/ssh-exceptions.rkt index b2432b3..da65fcc 100644 --- a/syndicate-ssh/ssh-exceptions.rkt +++ b/syndicate-ssh/ssh-exceptions.rkt @@ -1,44 +1,39 @@ -#lang racket/base +#lang syndicate ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones -;;; Exceptions and error-raising and -handling utilities used in structuring SSH sessions. +;;; Error-raising and -handling utilities used in structuring SSH sessions. -(provide (struct-out exn:fail:contract:protocol) +(provide (struct-out protocol-error) disconnect-with-error disconnect-with-error/local-info disconnect-with-error*) -;; An exn:fail:contract:protocol, when thrown by the transport (TODO: -;; clarify scope of this behaviour) will cause a SSH_MSG_DISCONNECT to -;; be sent to the remote party with the included reason code, using -;; the exn-message as the description. The local-info field is useful +;; A `protocol-error`, when asserted, will cause a SSH_MSG_DISCONNECT +;; to be sent to the remote party with the included reason code, using +;; `message` as the description. The `local-info` field is useful ;; information for diagnosing problems known to the local stack that ;; should not be transmitted to the remote party. For example, upon ;; detection of a MAC failure, it might be useful to know the expected ;; and actual MACs for debugging, but they should not be sent over the ;; wire because we could be experiencing some kind of attack. -(struct exn:fail:contract:protocol exn:fail:contract - (reason-code local-info originated-at-peer?) - #:transparent) +(struct protocol-error (reason-code message local-info originated-at-peer?) #:prefab) -;; Natural FormatString [Any ...] -> raised exn:fail:contract:protocol -(define (disconnect-with-error reason-code format-string . args) - (apply disconnect-with-error* #f '() reason-code format-string args)) +;; DS Natural FormatString [Any ...] -> signalled protocol-error +(define (disconnect-with-error ds reason-code format-string . args) + (apply disconnect-with-error* ds #f '() reason-code format-string args)) -;; Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol -(define (disconnect-with-error/local-info local-info reason-code format-string . args) - (apply disconnect-with-error* #f local-info reason-code format-string args)) +;; DS Any Natural FormatString [Any ...] -> signalled protocol-error +(define (disconnect-with-error/local-info ds local-info reason-code format-string . args) + (apply disconnect-with-error* ds #f local-info reason-code format-string args)) -;; Boolean Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol -(define (disconnect-with-error* originated-at-peer? +;; DS Boolean Any Natural FormatString [Any ...] -> signalled protocol-error +(define (disconnect-with-error* ds + originated-at-peer? local-info reason-code format-string . args) - (let ((message (apply format format-string args))) - (raise (exn:fail:contract:protocol message - (current-continuation-marks) - reason-code - local-info - originated-at-peer?)))) + (define message (apply format format-string args)) + (spawn (at ds (assert (protocol-error reason-code message local-info originated-at-peer?)))) + (error 'protocol-error "(~a) ~a: ~v" reason-code message local-info)) diff --git a/syndicate-ssh/ssh-host-key.rkt b/syndicate-ssh/ssh-host-key.rkt index cbad6af..e74207c 100644 --- a/syndicate-ssh/ssh-host-key.rkt +++ b/syndicate-ssh/ssh-host-key.rkt @@ -6,8 +6,8 @@ (require racket/port) (require net/base64) -(require (planet vyzo/crypto)) (require bitsyntax) +(require "crypto.rkt") (require "asn1-ber.rkt") (require "ssh-message-types.rkt") @@ -22,7 +22,6 @@ pieces->public-key host-key-algorithm->keys - host-key-algorithm->digest-type host-key-signature verify-host-key-signature! @@ -38,8 +37,8 @@ (define (bs->n bs) (bit-string->integer bs #t #t)) (define (n->bs n) (integer->bit-string n (* 8 (mpint-width n)) #t)) -(define (private-key->pieces key) - (bytes->private-key-pieces (private-key->bytes key))) +;; (define (private-key->pieces key) +;; (bytes->private-key-pieces (private-key->bytes key))) (define (bytes->private-key-pieces bs) (match (asn1-ber-decode-all bs) @@ -76,65 +75,32 @@ (define (pieces->private-key p) (match p - ((struct rsa-private-key (version n e d p q dmp1 dmq1 iqmp)) - (bytes->private-key pkey:rsa - (asn1-ber-encode `(0 16 ((0 2 ,(n->bs version)) - (0 2 ,(n->bs n)) - (0 2 ,(n->bs e)) - (0 2 ,(n->bs d)) - (0 2 ,(n->bs p)) - (0 2 ,(n->bs q)) - (0 2 ,(n->bs dmp1)) - (0 2 ,(n->bs dmq1)) - (0 2 ,(n->bs iqmp))))))) - ((struct dsa-private-key (version p q g y x)) - (bytes->private-key pkey:dsa - (asn1-ber-encode `(0 16 ((0 2 ,(n->bs version)) - (0 2 ,(n->bs p)) - (0 2 ,(n->bs q)) - (0 2 ,(n->bs g)) - (0 2 ,(n->bs y)) - (0 2 ,(n->bs x))))))))) + [(struct rsa-private-key (version n e d _p _q _dmp1 _dmq1 _iqmp)) + (datum->pk-key (list 'rsa 'private n e d) + 'rkt-private)] + [(struct dsa-private-key (version p q g y x)) + (datum->pk-key (list 'dsa 'private p q g y x) + 'rkt-private)])) (define (public-key->pieces key) - (match (asn1-ber-decode-all (public-key->bytes key)) - (`(0 16 ((0 2 ,n-bytes) - (0 2 ,e-bytes))) - (rsa-public-key (bs->n n-bytes) - (bs->n e-bytes))) - (`(0 16 ((0 2 ,public-key-bytes) ;; y - (0 2 ,p-bytes) - (0 2 ,q-bytes) - (0 2 ,g-bytes))) - (dsa-public-key (bs->n public-key-bytes) - (bs->n p-bytes) - (bs->n q-bytes) - (bs->n g-bytes))))) + (match (pk-key->datum key 'rkt-public) + [(list 'rsa 'public n e) + (rsa-public-key n e)] + [(list 'dsa 'public p q g public-key-bytes) + (dsa-public-key public-key-bytes p q g)])) (define (pieces->public-key p) (match p ((struct rsa-public-key (n e)) - (bytes->public-key pkey:rsa - (asn1-ber-encode `(0 16 ((0 2 ,(n->bs n)) - (0 2 ,(n->bs e))))))) + (datum->pk-key (list 'rsa 'public n e) 'rkt-public)) ((struct dsa-public-key (y p q g)) - (bytes->public-key pkey:dsa - (asn1-ber-encode `(0 16 ((0 2 ,(n->bs y)) - (0 2 ,(n->bs p)) - (0 2 ,(n->bs q)) - (0 2 ,(n->bs g))))))))) + (datum->pk-key (list 'dsa 'public p q g y) 'rkt-public)))) (define (host-key-algorithm->keys host-key-alg) (case host-key-alg ((ssh-dss) (values host-key-dsa-private host-key-dsa-public)) (else (error 'host-key-algorithm->keys "Unsupported host-key-alg ~v" host-key-alg)))) -(define (host-key-algorithm->digest-type host-key-alg) - (case host-key-alg - ((ssh-rsa) digest:sha1) - ((ssh-dss) digest:dss1) - (else (error 'host-key-algorithm->digest-type "Unsupported host-key-alg ~v" host-key-alg)))) - (define (host-key-signature private-key host-key-alg exchange-hash) (case host-key-alg ((ssh-rsa) @@ -142,7 +108,7 @@ ;; local-algorithm-list in ssh-transport.rkt. (error 'host-key-signature "ssh-rsa host key signatures unimplemented")) ((ssh-dss) - (match (asn1-ber-decode-all (sign private-key digest:dss1 exchange-hash)) + (match (asn1-ber-decode-all (pk-sign private-key exchange-hash)) (`(0 16 ((0 2 ,r-bytes) (0 2 ,s-bytes))) (bit-string (#"ssh-dss" :: (t:string)) @@ -167,7 +133,7 @@ (s :: big-endian integer bits 160) ] (asn1-ber-encode `(0 16 ((0 2 ,(n->bs r)) (0 2 ,(n->bs s)))))))))) - (when (not (verify public-key digest:dss1 signature exchange-hash)) + (when (not (pk-verify public-key exchange-hash signature)) (error 'verify-host-key-signature! "Signature mismatch"))))) (define (pieces->ssh-host-key pieces) @@ -207,7 +173,8 @@ #""))))) (define host-key-dsa-private (load-private-key "test-dsa-key")) -(define host-key-dsa-public (pkey->public-key host-key-dsa-private)) +(define host-key-dsa-public (pk-key->public-only-key host-key-dsa-private)) -(check-equal? (public-key->bytes (pieces->public-key (public-key->pieces host-key-dsa-public))) - (public-key->bytes host-key-dsa-private)) +(check-equal? (pk-key->datum (pieces->public-key (public-key->pieces host-key-dsa-public)) + 'SubjectPublicKeyInfo) + (pk-key->datum host-key-dsa-private 'SubjectPublicKeyInfo)) diff --git a/syndicate-ssh/ssh-session.rkt b/syndicate-ssh/ssh-session.rkt index 36bb278..c8f8185 100644 --- a/syndicate-ssh/ssh-session.rkt +++ b/syndicate-ssh/ssh-session.rkt @@ -1,25 +1,20 @@ -#lang racket/base +#lang syndicate ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones (require bitsyntax) -(require (planet vyzo/crypto:2:3)) - -(require racket/set) -(require racket/match) +(require syndicate/drivers/timer) +(require (only-in file/sha1 sha1)) +(require "crypto.rkt") (require "oakley-groups.rkt") - (require "ssh-host-key.rkt") - (require "ssh-numbers.rkt") (require "ssh-message-types.rkt") (require "ssh-exceptions.rkt") (require "ssh-transport.rkt") (require "ssh-channel.rkt") -(require "marketplace-support.rkt") - (provide rekey-interval rekey-volume ssh-session) @@ -47,36 +42,7 @@ ;; as the given username for the given service. ;; TODO: When authentication is properly implemented, we will need ;; intermediate states here too. -(struct authenticated (username service) #:transparent) - -;; A PacketDispatcher is a Hashtable mapping Byte to PacketHandler. - -;; A PacketHandler is a (Bytes DecodedPacket ConnectionState -> Transition). -;; The raw received bytes of the packet are given because sometimes -;; cryptographic operations on the received bytes are mandated by the -;; protocol. - -;; TODO: Remove dispatch-table in favour of using the os2 subscription -;; mechanism to dispatch packets. I could do this now, but I'd lose -;; SSH_MSG_UNIMPLEMENTED support: I would need to be able to query the -;; current routing table to see whether there was an active listener -;; ready to take a given packet. - -;; A ConnectionState is a (connection ... TODO fix this) representing -;; the complete state of the SSH transport, authentication, and -;; connection layers. -(struct connection (discard-next-packet? - dispatch-table - total-transferred - rekey-state - authentication-state - channels ;; ListOf - is-server? - local-id - remote-id - session-id ;; starts off #f until initial keying - application-boot) ;; used when authentication completes - #:transparent) +(struct authenticated (username service) #:prefab) ;; Generic inputs into the exchange-hash part of key ;; exchange. Diffie-Hellman uses these fields along with the host key, @@ -98,102 +64,12 @@ ;; Packet dispatch and handling ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Bytes -> Byte -;; Retrieves the packet type byte from a packet. -(define (encoded-packet-msg-type encoded-packet) - (bytes-ref encoded-packet 0)) - -;; PacketDispatcher [ Byte Maybe ]* -> PacketDispatcher -;; Adds or removes handlers to or from the given PacketDispatcher. -(define (extend-packet-dispatcher core-dispatcher . key-value-pairs) - (let loop ((d core-dispatcher) - (key-value-pairs key-value-pairs)) - (cond - ((null? key-value-pairs) - d) - ((null? (cdr key-value-pairs)) - (error 'extend-packet-dispatcher - "Must call extend-packet-dispatcher with matched key/value pairs")) - (else - (loop (let ((packet-type-number (car key-value-pairs)) - (packet-handler-or-false (cadr key-value-pairs))) - (if packet-handler-or-false - (hash-set d packet-type-number packet-handler-or-false) - (hash-remove d packet-type-number))) - (cddr key-value-pairs)))))) - -;; ConnectionState [ Byte Maybe ]* -> ConnectionState -;; Installs (or removes) PacketHandlers in the given connection state; -;; see extend-packet-dispatcher. -(define (set-handlers conn . key-value-pairs) - (struct-copy connection conn - [dispatch-table (apply extend-packet-dispatcher - (connection-dispatch-table conn) - key-value-pairs)])) - -;; Transition Byte PacketHandler -> ConnectionState -;; Installs a PacketHandler that removes the installed dispatch entry -;; and then delegates to its argument. -(define (oneshot-handler conn packet-type-number packet-handler) - (set-handlers conn - packet-type-number - (lambda (packet message conn) - (packet-handler packet - message - (set-handlers conn packet-type-number #f))))) - -(define (dispatch-packet seq packet message conn) - (define packet-type-number (encoded-packet-msg-type packet)) - (if (and (not (rekey-wait? (connection-rekey-state conn))) - (or (not (ssh-msg-type-transport-layer? packet-type-number)) - (= packet-type-number SSH_MSG_SERVICE_REQUEST) - (= packet-type-number SSH_MSG_SERVICE_ACCEPT))) - ;; We're in the middle of some phase of an active key-exchange, - ;; and received a packet that's for a higher layer than the - ;; transport layer, or one of the forbidden types given at the - ;; send of RFC4253 section 7.1. - (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR - "Packets of type ~v forbidden while in key-exchange" - packet-type-number) - ;; We're either idling, or it's a permitted packet type while - ;; performing key exchange. Look it up in the dispatch table. - (let ((handler (hash-ref (connection-dispatch-table conn) - packet-type-number - #f))) - (if handler - (handler packet message conn) - (transition conn - (send-message (outbound-packet (ssh-msg-unimplemented seq)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Handlers for core transport packet types -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; PacketHandler for handling SSH_MSG_DISCONNECT. -(define (handle-msg-disconnect packet message conn) - (disconnect-with-error* #t - '() - (ssh-msg-disconnect-reason-code message) - "Received SSH_MSG_DISCONNECT with reason code ~a and message ~s" - (ssh-msg-disconnect-reason-code message) - (bytes->string/utf-8 (bit-string->bytes - (ssh-msg-disconnect-description message))))) - -;; PacketHandler for handling SSH_MSG_IGNORE. -(define (handle-msg-ignore packet message conn) - (transition conn)) - -;; PacketHandler for handling SSH_MSG_UNIMPLEMENTED. -(define (handle-msg-unimplemented packet message conn) - (disconnect-with-error/local-info - `((offending-sequence-number ,(ssh-msg-unimplemented-sequence-number message))) - SSH_DISCONNECT_PROTOCOL_ERROR - "Disconnecting because of received SSH_MSG_UNIMPLEMENTED.")) - -;; PacketHandler for handling SSH_MSG_DEBUG. -(define (handle-msg-debug packet message conn) - (log-debug (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message)) - (transition conn)) +;; (task Nat Bytes SshMsg) +;; (task-accepted Nat) +;; Message handlers subscribe to `task`s, and assert `task-accepted` in reply. +;; If they do not timely assert `task-accepted`, SSH_MSG_UNIMPLEMENTED is generated. +(struct task (seq packet message) #:prefab) +(struct task-accepted (seq) #:prefab) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Key Exchange @@ -203,28 +79,24 @@ (rekey-wait (+ (current-seconds) delta-seconds) (+ total-transferred delta-bytes))) -(define (time-to-rekey? rekey conn) - (and (rekey-wait? rekey) - (or (>= (current-seconds) (rekey-wait-deadline rekey)) - (>= (connection-total-transferred conn) (rekey-wait-threshold-bytes rekey))))) - -;; (SshMsgKexinit -> Symbol) SshMsgKexinit SshMsgKexinit -> Symbol +;; DS (SshMsgKexinit -> Symbol) SshMsgKexinit SshMsgKexinit -> Symbol ;; Computes the name of the "best" algorithm choice at the given ;; getter, using the rules from the RFC and the client and server ;; algorithm precedence lists. -(define (best-result getter client-algs server-algs) +(define (best-result conn-ds getter client-algs server-algs) (define client-list0 (getter client-algs)) (define server-list (getter server-algs)) (let loop ((client-list client-list0)) (cond - ((null? client-list) (disconnect-with-error/local-info - `((client-list ,client-list0) - (server-list ,server-list)) - SSH_DISCONNECT_KEY_EXCHANGE_FAILED - "Could not agree on a suitable algorithm for ~v" - getter)) - ((memq (car client-list) server-list) (car client-list)) - (else (loop (cdr client-list)))))) + ((null? client-list) (disconnect-with-error/local-info + conn-ds + `((client-list ,client-list0) + (server-list ,server-list)) + SSH_DISCONNECT_KEY_EXCHANGE_FAILED + "Could not agree on a suitable algorithm for ~v" + getter)) + ((memq (car client-list) server-list) (car client-list)) + (else (loop (cdr client-list)))))) ;; ExchangeHashInfo Bytes Natural Natural Natural -> Bytes ;; Computes the session ID as defined by SSH's DH key exchange method. @@ -241,117 +113,115 @@ (k :: (t:mpint)))))) (sha1 block-to-hash))) -;; ExchangeHashInfo Symbol Symbol ConnectionState -;; (Bytes Bytes Symbol ConnectionState -> ConnectionState) -;; -> Transition +;; DS ExchangeHashInfo Symbol Symbol (Bytes Bytes Symbol -> Void) -> Void ;; Performs the server's half of the Diffie-Hellman key exchange protocol. -(define (perform-server-key-exchange hash-info kex-alg host-key-alg conn finish) - (case kex-alg - [(diffie-hellman-group14-sha1 diffie-hellman-group1-sha1) +(define (perform-server-key-exchange conn-ds hash-info kex-alg host-key-alg finish) + (match kex-alg + [(or 'diffie-hellman-group14-sha1 'diffie-hellman-group1-sha1) (define group (if (eq? kex-alg 'diffie-hellman-group14-sha1) dh:oakley-group-14 dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2 - (define-values (private-key public-key) (generate-key group)) - (define public-key-as-integer (bit-string->integer public-key #t #f)) - (transition - (oneshot-handler conn - SSH_MSG_KEXDH_INIT - (lambda (packet message conn) - (define e (ssh-msg-kexdh-init-e message)) - (define e-width (mpint-width e)) - (define e-as-bytes (integer->bit-string e (* 8 e-width) #t)) - (define shared-secret (compute-key private-key e-as-bytes)) - (define hash-alg sha1) - (define-values (host-key-private host-key-public) - (host-key-algorithm->keys host-key-alg)) - (define host-key-bytes - (pieces->ssh-host-key (public-key->pieces host-key-public))) - (define exchange-hash - (dh-exchange-hash hash-info - host-key-bytes - e - public-key-as-integer - (bit-string->integer shared-secret #t #f))) - (define h-signature (host-key-signature host-key-private - host-key-alg - exchange-hash)) - (sequence-actions (transition conn) - (send-message (outbound-packet - (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes) - public-key-as-integer - (bit-string->bytes h-signature)))) - (lambda (conn) - (finish shared-secret exchange-hash hash-alg conn))))))] - [else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED - "Bad key-exchange algorithm ~v" kex-alg)])) + (define private-key (generate-private-key group)) + (match-define (list 'dh 'public _p _g public-key-as-integer) + (pk-key->datum private-key 'rkt-public)) + (react + (at conn-ds + (during (task $seq _ (ssh-msg-kexdh-init $e)) + (at conn-ds (assert (task-accepted seq))) + (on-start (define e-width (mpint-width e)) + (define e-as-bytes (integer->bit-string e (* 8 e-width) #t)) + (define shared-secret (pk-derive-secret private-key e-as-bytes)) + (define hash-alg sha1) + (define-values (host-key-private host-key-public) + (host-key-algorithm->keys host-key-alg)) + (define host-key-bytes + (pieces->ssh-host-key (public-key->pieces host-key-public))) + (define exchange-hash + (dh-exchange-hash hash-info + host-key-bytes + e + public-key-as-integer + (bit-string->integer shared-secret #t #f))) + (define h-signature (host-key-signature host-key-private + host-key-alg + exchange-hash)) + (send! conn-ds (outbound-packet + (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes) + public-key-as-integer + (bit-string->bytes h-signature)))) + (finish shared-secret exchange-hash hash-alg)))))] + [_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED + "Bad key-exchange algorithm ~v" kex-alg)])) -;; ExchangeHashInfo Symbol Symbol ConnectionState -;; (Bytes Bytes Symbol ConnectionState -> ConnectionState) -;; -> Transition +;; DS ExchangeHashInfo Symbol Symbol (Bytes Bytes Symbol -> Void) -> Void ;; Performs the client's half of the Diffie-Hellman key exchange protocol. -(define (perform-client-key-exchange hash-info kex-alg host-key-alg conn finish) - (case kex-alg - [(diffie-hellman-group14-sha1 diffie-hellman-group1-sha1) +(define (perform-client-key-exchange conn-ds hash-info kex-alg host-key-alg finish) + (match kex-alg + [(or 'diffie-hellman-group14-sha1 'diffie-hellman-group1-sha1) (define group (if (eq? kex-alg 'diffie-hellman-group14-sha1) dh:oakley-group-14 dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2 - (define-values (private-key public-key) (generate-key group)) - (define public-key-as-integer (bit-string->integer public-key #t #f)) - (sequence-actions (transition conn) - (send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))) - (lambda (conn) - (transition - (oneshot-handler conn - SSH_MSG_KEXDH_REPLY - (lambda (packet message conn) - (define f (ssh-msg-kexdh-reply-f message)) - (define f-width (mpint-width f)) - (define f-as-bytes (integer->bit-string f (* 8 f-width) #t)) - (define shared-secret (compute-key private-key f-as-bytes)) - (define hash-alg sha1) - (define host-key-bytes (ssh-msg-kexdh-reply-host-key message)) - (define host-public-key - (pieces->public-key (ssh-host-key->pieces host-key-bytes))) - (define exchange-hash - (dh-exchange-hash hash-info - host-key-bytes - public-key-as-integer - f - (bit-string->integer shared-secret #t #f))) - (verify-host-key-signature! host-public-key - host-key-alg - exchange-hash - (ssh-msg-kexdh-reply-h-signature - message)) - (finish shared-secret exchange-hash hash-alg conn))))))] - [else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED - "Bad key-exchange algorithm ~v" kex-alg)])) + (define private-key (generate-private-key group)) + (match-define (list 'dh 'public _p _g public-key-as-integer) + (pk-key->datum private-key 'rkt-public)) + (send! conn-ds (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))) + (react + (at conn-ds + (during (task $seq _ (ssh-msg-kexdh-reply $host-key-bytes $f $h-signature)) + (at conn-ds (assert (task-accepted seq))) + (on-start (define f-width (mpint-width f)) + (define f-as-bytes (integer->bit-string f (* 8 f-width) #t)) + (define shared-secret (pk-derive-secret private-key f-as-bytes)) + (define hash-alg sha1) + (define host-public-key + (pieces->public-key (ssh-host-key->pieces host-key-bytes))) + (define exchange-hash + (dh-exchange-hash hash-info + host-key-bytes + public-key-as-integer + f + (bit-string->integer shared-secret #t #f))) + (verify-host-key-signature! host-public-key + host-key-alg + exchange-hash + h-signature) + (finish shared-secret exchange-hash hash-alg)))))] + [_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED + "Bad key-exchange algorithm ~v" kex-alg)])) -;; PacketHandler for handling SSH_MSG_KEXINIT. -(define (handle-msg-kexinit packet message conn) - (define rekey (connection-rekey-state conn)) - (when (rekey-in-progress? rekey) - (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR - "Received SSH_MSG_KEXINIT during ongoing key exchange")) - (define local-algs (if (rekey-local? rekey) - (rekey-local-local-algorithms rekey) - ((local-algorithm-list)))) +(define (do-kexinit conn-ds + ground-ds + #:packet packet + #:message message + #:rekey-state rekey-state + #:is-server? is-server? + #:local-id local-id + #:remote-id remote-id + #:session-id session-id + #:total-transferred total-transferred + #:discard-next-packet? discard-next-packet?) + (define local-algs + (match (rekey-state) + [(? rekey-wait?) ((local-algorithm-list))] + [(rekey-local local-algs) local-algs] + [(? rekey-in-progress?) + (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR + "Received SSH_MSG_KEXINIT during ongoing key exchange")])) (define encoded-local-algs (ssh-message-encode local-algs)) (define remote-algs message) (define encoded-remote-algs packet) - (define is-server? (connection-is-server? conn)) (define c (if is-server? remote-algs local-algs)) (define s (if is-server? local-algs remote-algs)) - (define kex-alg (best-result ssh-msg-kexinit-kex_algorithms c s)) - (define host-key-alg (best-result ssh-msg-kexinit-server_host_key_algorithms c s)) - (define c2s-enc (best-result ssh-msg-kexinit-encryption_algorithms_client_to_server c s)) - (define s2c-enc (best-result ssh-msg-kexinit-encryption_algorithms_server_to_client c s)) - (define c2s-mac (best-result ssh-msg-kexinit-mac_algorithms_client_to_server c s)) - (define s2c-mac (best-result ssh-msg-kexinit-mac_algorithms_server_to_client c s)) - (define c2s-zip (best-result ssh-msg-kexinit-compression_algorithms_client_to_server c s)) - (define s2c-zip (best-result ssh-msg-kexinit-compression_algorithms_server_to_client c s)) + (define kex-alg (best-result conn-ds ssh-msg-kexinit-kex_algorithms c s)) + (define host-key-alg (best-result conn-ds ssh-msg-kexinit-server_host_key_algorithms c s)) + (define c2s-enc (best-result conn-ds ssh-msg-kexinit-encryption_algorithms_client_to_server c s)) + (define s2c-enc (best-result conn-ds ssh-msg-kexinit-encryption_algorithms_server_to_client c s)) + (define c2s-mac (best-result conn-ds ssh-msg-kexinit-mac_algorithms_client_to_server c s)) + (define s2c-mac (best-result conn-ds ssh-msg-kexinit-mac_algorithms_server_to_client c s)) + (define c2s-zip (best-result conn-ds ssh-msg-kexinit-compression_algorithms_client_to_server c s)) + (define s2c-zip (best-result conn-ds ssh-msg-kexinit-compression_algorithms_server_to_client c s)) ;; Ignore languages. ;; Don't check the reserved field here, either. TODO: should we? @@ -377,531 +247,540 @@ (guess-matches? c2s-zip ssh-msg-kexinit-compression_algorithms_client_to_server) (guess-matches? s2c-zip ssh-msg-kexinit-compression_algorithms_server_to_client))))) - (define (continue-after-discard conn) - ((if is-server? - perform-server-key-exchange - perform-client-key-exchange) - (if is-server? - (exchange-hash-info (connection-remote-id conn) - (connection-local-id conn) - encoded-remote-algs - encoded-local-algs) - (exchange-hash-info (connection-local-id conn) - (connection-remote-id conn) - encoded-local-algs - encoded-remote-algs)) - kex-alg - host-key-alg - conn - continue-after-key-exchange)) + (when should-discard-first-kex-packet + (discard-next-packet? #t)) - (define (continue-after-key-exchange shared-secret exchange-hash hash-alg conn) - (define session-id (if (connection-session-id conn) - (connection-session-id conn) ;; don't overwrite existing ID - exchange-hash)) - (define k-h-prefix (bit-string ((bit-string->integer shared-secret #t #f) :: (t:mpint)) - (exchange-hash :: binary))) - (define (derive-key kind needed-bytes-or-false) - (let extend ((key (hash-alg (bit-string->bytes - (bit-string (k-h-prefix :: binary) - (kind :: binary) - (session-id :: binary)))))) - (cond - ((eq? #f needed-bytes-or-false) - key) - ((>= (bytes-length key) needed-bytes-or-false) - (subbytes key 0 needed-bytes-or-false)) - (else - (extend (bytes-append key (hash-alg (bit-string->bytes - (bit-string (k-h-prefix :: binary) - (key :: binary)))))))))) - (transition - (oneshot-handler (struct-copy connection conn - [session-id session-id]) ;; just in case it changed - SSH_MSG_NEWKEYS - (lambda (newkeys-packet newkeys-message conn) - ;; First, send our SSH_MSG_NEWKEYS, - ;; incrementing the various counters, and then - ;; apply the new algorithms. Also arm our rekey - ;; timer. - (define new-rekey-state (rekey-in-seconds-or-bytes - (rekey-interval) - (rekey-volume) - (connection-total-transferred conn))) - (transition - (set-handlers - (struct-copy connection conn [rekey-state new-rekey-state]) - SSH_MSG_SERVICE_REQUEST handle-msg-service-request) - (send-message (outbound-packet (ssh-msg-newkeys))) - (send-message - (new-keys (connection-is-server? conn) - derive-key - c2s-enc s2c-enc - c2s-mac s2c-mac - c2s-zip s2c-zip)) - (send-message (set-timer 'rekey-timer - (* (rekey-wait-deadline new-rekey-state) 1000) - 'absolute))))))) + (when (rekey-wait? (rekey-state)) + (rekey-state (rekey-local local-algs)) + (send! conn-ds (outbound-packet local-algs))) - (sequence-actions (continue-after-discard conn) - (when should-discard-first-kex-packet - (lambda (conn) (transition (struct-copy connection conn [discard-next-packet? #t])))) - (lambda (conn) - (if (rekey-wait? (connection-rekey-state conn)) - (transition (struct-copy connection conn [rekey-state (rekey-local local-algs)]) - (send-message (outbound-packet local-algs))) - (transition conn))))) + ((if is-server? perform-server-key-exchange perform-client-key-exchange) + conn-ds + (if is-server? + (exchange-hash-info remote-id local-id encoded-remote-algs encoded-local-algs) + (exchange-hash-info local-id remote-id encoded-local-algs encoded-remote-algs)) + kex-alg + host-key-alg + (lambda (shared-secret exchange-hash hash-alg) + (when (not (session-id)) (session-id exchange-hash)) ;; don't overwrite existing ID + (define k-h-prefix (bit-string ((bit-string->integer shared-secret #t #f) :: (t:mpint)) + (exchange-hash :: binary))) + (define (derive-key kind needed-bytes-or-false) + (let extend ((key (hash-alg (bit-string->bytes + (bit-string (k-h-prefix :: binary) + (kind :: binary) + ((session-id) :: binary)))))) + (cond + ((eq? #f needed-bytes-or-false) + key) + ((>= (bytes-length key) needed-bytes-or-false) + (subbytes key 0 needed-bytes-or-false)) + (else + (extend (bytes-append key (hash-alg (bit-string->bytes + (bit-string (k-h-prefix :: binary) + (key :: binary)))))))))) + (react + (at conn-ds + (during (task $seq _ (ssh-msg-newkeys)) + (at conn-ds (assert (task-accepted seq))) + ;; First, send our SSH_MSG_NEWKEYS, incrementing the + ;; various counters, and then apply the new algorithms. + ;; Also arm our rekey timer. + (rekey-state (rekey-in-seconds-or-bytes (rekey-interval) + (rekey-volume) + (total-transferred))) + (send! conn-ds 'enable-service-request!) + (send! conn-ds (outbound-packet (ssh-msg-newkeys))) + (send! conn-ds (new-keys is-server? + derive-key + c2s-enc s2c-enc + c2s-mac s2c-mac + c2s-zip s2c-zip)) + (send! ground-ds (SetTimer 'rekey-timer + (* (rekey-wait-deadline (rekey-state)) 1000) + (TimerKind-absolute))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Service request manager ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (handle-msg-service-request packet message conn) - (define service (bit-string->bytes (ssh-msg-service-request-service-name message))) - (match service - [#"ssh-userauth" - (if (connection-authentication-state conn) - (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE - "Repeated authentication is not permitted") - (sequence-actions (transition conn) - (send-message (outbound-packet (ssh-msg-service-accept service))) - (lambda (conn) (transition - (oneshot-handler conn - SSH_MSG_USERAUTH_REQUEST - handle-msg-userauth-request)))))] - [else - (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE - "Service ~v not supported" - service)])) +;; (define (handle-msg-service-request packet message conn) +;; (define service (bit-string->bytes (ssh-msg-service-request-service-name message))) +;; (match service +;; [#"ssh-userauth" +;; (if (connection-authentication-state conn) +;; (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE +;; "Repeated authentication is not permitted") +;; (sequence-actions (transition conn) +;; (send-message (outbound-packet (ssh-msg-service-accept service))) +;; (lambda (conn) (transition +;; (oneshot-handler conn +;; SSH_MSG_USERAUTH_REQUEST +;; handle-msg-userauth-request)))))] +;; [else +;; (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE +;; "Service ~v not supported" +;; service)])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User authentication ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (handle-msg-userauth-request packet message conn) - (define user-name (bit-string->bytes (ssh-msg-userauth-request-user-name message))) - (define service-name (bit-string->bytes (ssh-msg-userauth-request-service-name message))) - (cond - [(and (positive? (bytes-length user-name)) - (equal? service-name #"ssh-connection")) - ;; TODO: Actually implement client authentication - (sequence-actions (transition conn) - (send-message (outbound-packet (ssh-msg-userauth-success))) - (lambda (conn) - (start-connection-service - (set-handlers (struct-copy connection conn - [authentication-state (authenticated user-name service-name)]) - SSH_MSG_USERAUTH_REQUEST - (lambda (packet message conn) - ;; RFC4252 section 5.1 page 6 - conn)))) - (lambda (conn) - (transition conn - ;; TODO: canary for NESTED VM!: #:exit-signal? #t - (spawn-vm #:debug-name 'ssh-application-vm - ((connection-application-boot conn) user-name)))))] - [else - (transition conn - (send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))])) +;; (define (handle-msg-userauth-request packet message conn) +;; (define user-name (bit-string->bytes (ssh-msg-userauth-request-user-name message))) +;; (define service-name (bit-string->bytes (ssh-msg-userauth-request-service-name message))) +;; (cond +;; [(and (positive? (bytes-length user-name)) +;; (equal? service-name #"ssh-connection")) +;; ;; TODO: Actually implement client authentication +;; (sequence-actions (transition conn) +;; (send-message (outbound-packet (ssh-msg-userauth-success))) +;; (lambda (conn) +;; (start-connection-service +;; (set-handlers (struct-copy connection conn +;; [authentication-state (authenticated user-name service-name)]) +;; SSH_MSG_USERAUTH_REQUEST +;; (lambda (packet message conn) +;; ;; RFC4252 section 5.1 page 6 +;; conn)))) +;; (lambda (conn) +;; (transition conn +;; ;; TODO: canary for NESTED VM!: #:exit-signal? #t +;; (spawn-vm #:debug-name 'ssh-application-vm +;; ((connection-application-boot conn) user-name)))))] +;; [else +;; (transition conn +;; (send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Channel management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (unused-local-channel-ref conn) - (define (bump-candidate candidate) - (modulo (+ candidate 1) #x100000000)) - (define first-candidate (match (connection-channels conn) - ['() 0] - [(cons ch _) (bump-candidate (ssh-channel-local-ref ch))])) - (let examine-candidate ((candidate first-candidate)) - (let loop ((chs (connection-channels conn))) - (cond - [(null? chs) candidate] - [(= (ssh-channel-local-ref (car chs)) candidate) - (examine-candidate (bump-candidate candidate))] - [else (loop (cdr chs))])))) +;; (define (unused-local-channel-ref conn) +;; (define (bump-candidate candidate) +;; (modulo (+ candidate 1) #x100000000)) +;; (define first-candidate (match (connection-channels conn) +;; ['() 0] +;; [(cons ch _) (bump-candidate (ssh-channel-local-ref ch))])) +;; (let examine-candidate ((candidate first-candidate)) +;; (let loop ((chs (connection-channels conn))) +;; (cond +;; [(null? chs) candidate] +;; [(= (ssh-channel-local-ref (car chs)) candidate) +;; (examine-candidate (bump-candidate candidate))] +;; [else (loop (cdr chs))])))) -(define (replacef proc updater creator lst) - (let loop ((lst lst)) - (cond [(null? lst) (list (creator))] - [(proc (car lst)) (cons (updater (car lst)) (cdr lst))] - [else (cons (car lst) (loop (cdr lst)))]))) +;; (define (replacef proc updater creator lst) +;; (let loop ((lst lst)) +;; (cond [(null? lst) (list (creator))] +;; [(proc (car lst)) (cons (updater (car lst)) (cdr lst))] +;; [else (cons (car lst) (loop (cdr lst)))]))) -(define (remf proc lst) - (cond [(null? lst) '()] - [(proc (car lst)) (cdr lst)] - [else (cons (car lst) (remf proc (cdr lst)))])) +;; (define (remf proc lst) +;; (cond [(null? lst) '()] +;; [(proc (car lst)) (cdr lst)] +;; [else (cons (car lst) (remf proc (cdr lst)))])) -;; ChannelName -> ChannelState -> Boolean -(define ((ssh-channel-name=? cname) c) - (equal? (ssh-channel-name c) cname)) +;; ;; ChannelName -> ChannelState -> Boolean +;; (define ((ssh-channel-name=? cname) c) +;; (equal? (ssh-channel-name c) cname)) -;; Connection Uint32 -> ChannelState -(define (get-channel conn local-ref) - (define ch (findf (lambda (c) (equal? (ssh-channel-local-ref c) local-ref)) - (connection-channels conn))) - (when (not ch) - (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR - "Attempt to use known channel local-ref ~v" - local-ref)) - ch) +;; ;; Connection Uint32 -> ChannelState +;; (define (get-channel conn local-ref) +;; (define ch (findf (lambda (c) (equal? (ssh-channel-local-ref c) local-ref)) +;; (connection-channels conn))) +;; (when (not ch) +;; (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR +;; "Attempt to use known channel local-ref ~v" +;; local-ref)) +;; ch) -;; ChannelName Maybe Connection -> Connection -(define (update-channel cname updater conn) - (struct-copy connection conn - [channels - (replacef (ssh-channel-name=? cname) - updater - (lambda () (updater (ssh-channel cname - (unused-local-channel-ref conn) - #f - #f - 'neither))) - (connection-channels conn))])) +;; ;; ChannelName Maybe Connection -> Connection +;; (define (update-channel cname updater conn) +;; (struct-copy connection conn +;; [channels +;; (replacef (ssh-channel-name=? cname) +;; updater +;; (lambda () (updater (ssh-channel cname +;; (unused-local-channel-ref conn) +;; #f +;; #f +;; 'neither))) +;; (connection-channels conn))])) -;; ChannelName Connection -> Connection -(define (discard-channel cname conn) - (struct-copy connection conn - [channels - (remf (ssh-channel-name=? cname) (connection-channels conn))])) +;; ;; ChannelName Connection -> Connection +;; (define (discard-channel cname conn) +;; (struct-copy connection conn +;; [channels +;; (remf (ssh-channel-name=? cname) (connection-channels conn))])) -;; CloseState Either<'local,'remote> -> CloseState -(define (update-close-state old-state action) - (define local? (case action ((local) #t) ((remote) #f))) - (case old-state - ((neither) (if local? 'local 'remote)) - ((local) (if local? 'local 'both)) - ((remote) (if local? 'both 'remote)) - ((both) 'both))) +;; ;; CloseState Either<'local,'remote> -> CloseState +;; (define (update-close-state old-state action) +;; (define local? (case action ((local) #t) ((remote) #f))) +;; (case old-state +;; ((neither) (if local? 'local 'remote)) +;; ((local) (if local? 'local 'both)) +;; ((remote) (if local? 'both 'remote)) +;; ((both) 'both))) -(define (maybe-close-channel cname conn action) - (cond - [(findf (ssh-channel-name=? cname) (connection-channels conn)) => - (lambda (ch) - (define old-close-state (ssh-channel-close-state ch)) - (define new-close-state (update-close-state old-close-state action)) - (transition (if (eq? new-close-state 'both) - (discard-channel ch conn) - (update-channel cname - (lambda (ch) - (struct-copy ssh-channel ch - [close-state new-close-state])) - conn)) - (case action - [(local) - (case old-close-state - [(neither remote) - (list (send-message (outbound-packet - (ssh-msg-channel-close (ssh-channel-remote-ref ch)))))] - [else (list)])] - [(remote) - (case old-close-state - [(neither local) - (list (delete-endpoint (list cname 'outbound)) - (delete-endpoint (list cname 'inbound)))] - [else (list)])])))] - [else (transition conn)])) +;; (define (maybe-close-channel cname conn action) +;; (cond +;; [(findf (ssh-channel-name=? cname) (connection-channels conn)) => +;; (lambda (ch) +;; (define old-close-state (ssh-channel-close-state ch)) +;; (define new-close-state (update-close-state old-close-state action)) +;; (transition (if (eq? new-close-state 'both) +;; (discard-channel ch conn) +;; (update-channel cname +;; (lambda (ch) +;; (struct-copy ssh-channel ch +;; [close-state new-close-state])) +;; conn)) +;; (case action +;; [(local) +;; (case old-close-state +;; [(neither remote) +;; (list (send-message (outbound-packet +;; (ssh-msg-channel-close (ssh-channel-remote-ref ch)))))] +;; [else (list)])] +;; [(remote) +;; (case old-close-state +;; [(neither local) +;; (list (delete-endpoint (list cname 'outbound)) +;; (delete-endpoint (list cname 'inbound)))] +;; [else (list)])])))] +;; [else (transition conn)])) -(define (channel-endpoints cname initial-message-producer) - (define inbound-stream-name (channel-stream-name #t cname)) - (define outbound-stream-name (channel-stream-name #f cname)) - (define (! conn message) - (transition conn (send-message (outbound-packet message)))) - (list - (name-endpoint (list cname 'outbound) - (subscriber (channel-message outbound-stream-name (wild)) - (match-state conn - (on-presence (transition conn - (initial-message-producer inbound-stream-name outbound-stream-name))) - (on-absence (maybe-close-channel cname conn 'local)) - (on-message - [(channel-message _ body) - (let () - (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) - (define remote-ref (ssh-channel-remote-ref ch)) - (match body - [(channel-stream-data data-bytes) - ;; TODO: split data-bytes into packets if longer than max packet size - (! conn (ssh-msg-channel-data remote-ref data-bytes))] - [(channel-stream-extended-data type data-bytes) - (! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))] - [(channel-stream-eof) - (! conn (ssh-msg-channel-eof remote-ref))] - [(channel-stream-notify type data-bytes) - (! conn (ssh-msg-channel-request remote-ref type #f data-bytes))] - [(channel-stream-request type data-bytes) - (! conn (ssh-msg-channel-request remote-ref type #t data-bytes))] - [(channel-stream-open-failure reason description) - (! (discard-channel cname conn) - (ssh-msg-channel-open-failure remote-ref reason description #""))]))])))) - (name-endpoint (list cname 'inbound) - (publisher (channel-message inbound-stream-name (wild)) - (match-state conn - (on-message - [(channel-message _ body) - (let () - (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) - (define remote-ref (ssh-channel-remote-ref ch)) - (match body - [(channel-stream-config maximum-packet-size extra-data) - (if (channel-name-locally-originated? cname) - ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN. - (! conn (ssh-msg-channel-open (channel-name-type cname) - (ssh-channel-local-ref ch) - 0 - maximum-packet-size - extra-data)) - ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION. - (! conn (ssh-msg-channel-open-confirmation remote-ref - (ssh-channel-local-ref ch) - 0 - maximum-packet-size - extra-data)))] - [(channel-stream-credit count) - (! conn (ssh-msg-channel-window-adjust remote-ref count))] - [(channel-stream-ok) - (! conn (ssh-msg-channel-success remote-ref))] - [(channel-stream-fail) - (! conn (ssh-msg-channel-failure remote-ref))]))])))))) +;; (define (channel-endpoints cname initial-message-producer) +;; (define inbound-stream-name (channel-stream-name #t cname)) +;; (define outbound-stream-name (channel-stream-name #f cname)) +;; (define (! conn message) +;; (transition conn (send-message (outbound-packet message)))) +;; (list +;; (name-endpoint (list cname 'outbound) +;; (subscriber (channel-message outbound-stream-name (wild)) +;; (match-state conn +;; (on-presence (transition conn +;; (initial-message-producer inbound-stream-name outbound-stream-name))) +;; (on-absence (maybe-close-channel cname conn 'local)) +;; (on-message +;; [(channel-message _ body) +;; (let () +;; (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) +;; (define remote-ref (ssh-channel-remote-ref ch)) +;; (match body +;; [(channel-stream-data data-bytes) +;; ;; TODO: split data-bytes into packets if longer than max packet size +;; (! conn (ssh-msg-channel-data remote-ref data-bytes))] +;; [(channel-stream-extended-data type data-bytes) +;; (! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))] +;; [(channel-stream-eof) +;; (! conn (ssh-msg-channel-eof remote-ref))] +;; [(channel-stream-notify type data-bytes) +;; (! conn (ssh-msg-channel-request remote-ref type #f data-bytes))] +;; [(channel-stream-request type data-bytes) +;; (! conn (ssh-msg-channel-request remote-ref type #t data-bytes))] +;; [(channel-stream-open-failure reason description) +;; (! (discard-channel cname conn) +;; (ssh-msg-channel-open-failure remote-ref reason description #""))]))])))) +;; (name-endpoint (list cname 'inbound) +;; (publisher (channel-message inbound-stream-name (wild)) +;; (match-state conn +;; (on-message +;; [(channel-message _ body) +;; (let () +;; (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) +;; (define remote-ref (ssh-channel-remote-ref ch)) +;; (match body +;; [(channel-stream-config maximum-packet-size extra-data) +;; (if (channel-name-locally-originated? cname) +;; ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN. +;; (! conn (ssh-msg-channel-open (channel-name-type cname) +;; (ssh-channel-local-ref ch) +;; 0 +;; maximum-packet-size +;; extra-data)) +;; ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION. +;; (! conn (ssh-msg-channel-open-confirmation remote-ref +;; (ssh-channel-local-ref ch) +;; 0 +;; maximum-packet-size +;; extra-data)))] +;; [(channel-stream-credit count) +;; (! conn (ssh-msg-channel-window-adjust remote-ref count))] +;; [(channel-stream-ok) +;; (! conn (ssh-msg-channel-success remote-ref))] +;; [(channel-stream-fail) +;; (! conn (ssh-msg-channel-failure remote-ref))]))])))))) -(define (channel-notify conn ch inbound? body) - (transition conn - (send-message (channel-message (channel-stream-name inbound? (ssh-channel-name ch)) - body) - (if inbound? 'publisher 'subscriber)))) +;; (define (channel-notify conn ch inbound? body) +;; (transition conn +;; (send-message (channel-message (channel-stream-name inbound? (ssh-channel-name ch)) +;; body) +;; (if inbound? 'publisher 'subscriber)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Connection service ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (respond-to-opened-outbound-channel conn cname) - (if (and (ground? cname) - (not (memf (ssh-channel-name=? cname) (connection-channels conn)))) - (transition (update-channel cname values conn) - (channel-endpoints cname (lambda (inbound-stream outbound-stream) - '()))) - (transition conn))) +;; (define (respond-to-opened-outbound-channel conn cname) +;; (if (and (ground? cname) +;; (not (memf (ssh-channel-name=? cname) (connection-channels conn)))) +;; (transition (update-channel cname values conn) +;; (channel-endpoints cname (lambda (inbound-stream outbound-stream) +;; '()))) +;; (transition conn))) -(define (start-connection-service conn) - (sequence-actions - (transition - (set-handlers conn - ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request - SSH_MSG_CHANNEL_OPEN handle-msg-channel-open - SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation - SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure - SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust - SSH_MSG_CHANNEL_DATA handle-msg-channel-data - SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data - SSH_MSG_CHANNEL_EOF handle-msg-channel-eof - SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close - SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request - SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success - SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure)) - ;; Start responding to channel interest coming from the - ;; application. We are responding to channels appearing from the - ;; remote peer by virtue of our installation of the handler for - ;; SSH_MSG_CHANNEL_OPEN above. - (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) - (match-state conn - (match-conversation (channel-message (channel-stream-name #t cname) _) - (on-presence (respond-to-opened-outbound-channel conn cname))))) - (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) - (match-state conn - (match-conversation (channel-message (channel-stream-name #f cname) _) - (on-presence (respond-to-opened-outbound-channel conn cname))))))) +;; (define (start-connection-service conn) +;; (sequence-actions +;; (transition +;; (set-handlers conn +;; ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request +;; SSH_MSG_CHANNEL_OPEN handle-msg-channel-open +;; SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation +;; SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure +;; SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust +;; SSH_MSG_CHANNEL_DATA handle-msg-channel-data +;; SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data +;; SSH_MSG_CHANNEL_EOF handle-msg-channel-eof +;; SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close +;; SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request +;; SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success +;; SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure)) +;; ;; Start responding to channel interest coming from the +;; ;; application. We are responding to channels appearing from the +;; ;; remote peer by virtue of our installation of the handler for +;; ;; SSH_MSG_CHANNEL_OPEN above. +;; (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) +;; (match-state conn +;; (match-conversation (channel-message (channel-stream-name #t cname) _) +;; (on-presence (respond-to-opened-outbound-channel conn cname))))) +;; (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) +;; (match-state conn +;; (match-conversation (channel-message (channel-stream-name #f cname) _) +;; (on-presence (respond-to-opened-outbound-channel conn cname))))))) -(define (handle-msg-channel-open packet message conn) - (match-define (ssh-msg-channel-open channel-type* - remote-ref - initial-window-size - maximum-packet-size - extra-request-data*) - message) +;; (define (handle-msg-channel-open packet message conn) +;; (match-define (ssh-msg-channel-open channel-type* +;; remote-ref +;; initial-window-size +;; maximum-packet-size +;; extra-request-data*) +;; message) - (when (memf (lambda (c) (equal? (ssh-channel-remote-ref c) remote-ref)) - (connection-channels conn)) - (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR - "Attempt to open already-open channel ~v" - remote-ref)) +;; (when (memf (lambda (c) (equal? (ssh-channel-remote-ref c) remote-ref)) +;; (connection-channels conn)) +;; (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR +;; "Attempt to open already-open channel ~v" +;; remote-ref)) - (define channel-type (bit-string->bytes channel-type*)) - (define extra-request-data (bit-string->bytes extra-request-data*)) - (define cname (channel-name #f channel-type remote-ref)) +;; (define channel-type (bit-string->bytes channel-type*)) +;; (define extra-request-data (bit-string->bytes extra-request-data*)) +;; (define cname (channel-name #f channel-type remote-ref)) - (transition (update-channel cname - (lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref])) - conn) - (channel-endpoints cname - (lambda (inbound-stream outbound-stream) - (list (send-feedback - (channel-message outbound-stream - (channel-stream-config maximum-packet-size - extra-request-data))) - (send-feedback - (channel-message outbound-stream - (channel-stream-credit initial-window-size)))))))) +;; (transition (update-channel cname +;; (lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref])) +;; conn) +;; (channel-endpoints cname +;; (lambda (inbound-stream outbound-stream) +;; (list (send-feedback +;; (channel-message outbound-stream +;; (channel-stream-config maximum-packet-size +;; extra-request-data))) +;; (send-feedback +;; (channel-message outbound-stream +;; (channel-stream-credit initial-window-size)))))))) -(define (handle-msg-channel-open-confirmation packet message conn) - (match-define (ssh-msg-channel-open-confirmation local-ref - remote-ref - initial-window-size - maximum-packet-size - extra-request-data*) - message) - (define ch (get-channel conn local-ref)) - (define extra-request-data (bit-string->bytes extra-request-data*)) - (define outbound-stream (channel-stream-name #f (ssh-channel-name ch))) - (transition (update-channel (ssh-channel-name ch) - (lambda (c) - (struct-copy ssh-channel c - [remote-ref remote-ref] - [outbound-packet-size maximum-packet-size])) - conn) - (send-feedback (channel-message outbound-stream - (channel-stream-config maximum-packet-size - extra-request-data))) - (send-feedback (channel-message outbound-stream - (channel-stream-credit initial-window-size))))) +;; (define (handle-msg-channel-open-confirmation packet message conn) +;; (match-define (ssh-msg-channel-open-confirmation local-ref +;; remote-ref +;; initial-window-size +;; maximum-packet-size +;; extra-request-data*) +;; message) +;; (define ch (get-channel conn local-ref)) +;; (define extra-request-data (bit-string->bytes extra-request-data*)) +;; (define outbound-stream (channel-stream-name #f (ssh-channel-name ch))) +;; (transition (update-channel (ssh-channel-name ch) +;; (lambda (c) +;; (struct-copy ssh-channel c +;; [remote-ref remote-ref] +;; [outbound-packet-size maximum-packet-size])) +;; conn) +;; (send-feedback (channel-message outbound-stream +;; (channel-stream-config maximum-packet-size +;; extra-request-data))) +;; (send-feedback (channel-message outbound-stream +;; (channel-stream-credit initial-window-size))))) -(define (handle-msg-channel-open-failure packet message conn) - (match-define (ssh-msg-channel-open-failure local-ref - reason - description* - _) - message) - (define ch (get-channel conn local-ref)) - (define description (bit-string->bytes description*)) - (define inbound-stream (channel-stream-name #t (ssh-channel-name ch))) - (sequence-actions (transition conn) - (send-message (channel-message inbound-stream - (channel-stream-open-failure reason description))) - (lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote)))) +;; (define (handle-msg-channel-open-failure packet message conn) +;; (match-define (ssh-msg-channel-open-failure local-ref +;; reason +;; description* +;; _) +;; message) +;; (define ch (get-channel conn local-ref)) +;; (define description (bit-string->bytes description*)) +;; (define inbound-stream (channel-stream-name #t (ssh-channel-name ch))) +;; (sequence-actions (transition conn) +;; (send-message (channel-message inbound-stream +;; (channel-stream-open-failure reason description))) +;; (lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote)))) -(define (handle-msg-channel-window-adjust packet message conn) - (match-define (ssh-msg-channel-window-adjust local-ref count) message) - (define ch (get-channel conn local-ref)) - (channel-notify conn ch #f (channel-stream-credit count))) +;; (define (handle-msg-channel-window-adjust packet message conn) +;; (match-define (ssh-msg-channel-window-adjust local-ref count) message) +;; (define ch (get-channel conn local-ref)) +;; (channel-notify conn ch #f (channel-stream-credit count))) -(define (handle-msg-channel-data packet message conn) - (match-define (ssh-msg-channel-data local-ref data*) message) - (define data (bit-string->bytes data*)) - (define ch (get-channel conn local-ref)) - (channel-notify conn ch #t (channel-stream-data data))) +;; (define (handle-msg-channel-data packet message conn) +;; (match-define (ssh-msg-channel-data local-ref data*) message) +;; (define data (bit-string->bytes data*)) +;; (define ch (get-channel conn local-ref)) +;; (channel-notify conn ch #t (channel-stream-data data))) -(define (handle-msg-channel-extended-data packet message conn) - (match-define (ssh-msg-channel-extended-data local-ref type-code data*) message) - (define data (bit-string->bytes data*)) - (define ch (get-channel conn local-ref)) - (channel-notify conn ch #t (channel-stream-extended-data type-code data))) +;; (define (handle-msg-channel-extended-data packet message conn) +;; (match-define (ssh-msg-channel-extended-data local-ref type-code data*) message) +;; (define data (bit-string->bytes data*)) +;; (define ch (get-channel conn local-ref)) +;; (channel-notify conn ch #t (channel-stream-extended-data type-code data))) -(define (handle-msg-channel-eof packet message conn) - (define ch (get-channel conn (ssh-msg-channel-eof-recipient-channel message))) - (channel-notify conn ch #t (channel-stream-eof))) +;; (define (handle-msg-channel-eof packet message conn) +;; (define ch (get-channel conn (ssh-msg-channel-eof-recipient-channel message))) +;; (channel-notify conn ch #t (channel-stream-eof))) -(define (handle-msg-channel-close packet message conn) - (define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message))) - (maybe-close-channel (ssh-channel-name ch) conn 'remote)) +;; (define (handle-msg-channel-close packet message conn) +;; (define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message))) +;; (maybe-close-channel (ssh-channel-name ch) conn 'remote)) -(define (handle-msg-channel-request packet message conn) - (match-define (ssh-msg-channel-request local-ref type* want-reply? data*) message) - (define type (bit-string->bytes type*)) - (define data (bit-string->bytes data*)) - (define ch (get-channel conn local-ref)) - (channel-notify conn ch #t - (if want-reply? - (channel-stream-request type data) - (channel-stream-notify type data)))) +;; (define (handle-msg-channel-request packet message conn) +;; (match-define (ssh-msg-channel-request local-ref type* want-reply? data*) message) +;; (define type (bit-string->bytes type*)) +;; (define data (bit-string->bytes data*)) +;; (define ch (get-channel conn local-ref)) +;; (channel-notify conn ch #t +;; (if want-reply? +;; (channel-stream-request type data) +;; (channel-stream-notify type data)))) -(define (handle-msg-channel-success packet message conn) - (match-define (ssh-msg-channel-success local-ref) message) - (define ch (get-channel conn local-ref)) - (channel-notify conn ch #f (channel-stream-ok))) +;; (define (handle-msg-channel-success packet message conn) +;; (match-define (ssh-msg-channel-success local-ref) message) +;; (define ch (get-channel conn local-ref)) +;; (channel-notify conn ch #f (channel-stream-ok))) -(define (handle-msg-channel-failure packet message conn) - (match-define (ssh-msg-channel-failure local-ref) message) - (define ch (get-channel conn local-ref)) - (channel-notify conn ch #f (channel-stream-fail))) +;; (define (handle-msg-channel-failure packet message conn) +;; (match-define (ssh-msg-channel-failure local-ref) message) +;; (define ch (get-channel conn local-ref)) +;; (channel-notify conn ch #f (channel-stream-fail))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session main process ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (connection-username conn) - (match (connection-authentication-state conn) - ((authenticated username servicename) - username) - (else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR - "Not authenticated")))) - -(define ((bump-total amount) conn) - (transition - (struct-copy connection conn - [total-transferred (+ (connection-total-transferred conn) amount)]))) - -;; (K V A -> A) A Hash -> A -(define (hash-fold fn seed hash) - (do ((pos (hash-iterate-first hash) (hash-iterate-next hash pos)) - (seed seed (fn (hash-iterate-key hash pos) (hash-iterate-value hash pos) seed))) - ((not pos) seed))) - -(define (maybe-rekey conn) - (define rekey (connection-rekey-state conn)) - (if (time-to-rekey? rekey conn) - (let ((algs ((local-algorithm-list)))) - (transition (struct-copy connection conn [rekey-state (rekey-local algs)]) - (send-message (outbound-packet algs)))) - (transition conn))) - -;; PacketDispatcher. Handles the core transport message types. -(define base-packet-dispatcher - (hasheq SSH_MSG_DISCONNECT handle-msg-disconnect - SSH_MSG_IGNORE handle-msg-ignore - SSH_MSG_UNIMPLEMENTED handle-msg-unimplemented - SSH_MSG_DEBUG handle-msg-debug - SSH_MSG_KEXINIT handle-msg-kexinit)) - -(define (ssh-session self-pid - local-identification-string +(define (ssh-session conn-ds + ground-ds + local-identification-string peer-identification-string application-boot session-role) - (transition (connection #f - base-packet-dispatcher - 0 - (rekey-in-seconds-or-bytes -1 -1 0) - #f - '() - (case session-role ((client) #f) ((server) #t)) - local-identification-string - peer-identification-string - #f - application-boot) + (define-field rekey-state (rekey-in-seconds-or-bytes -1 -1 0)) + (define-field session-id #f) + (define-field total-transferred 0) + (define-field discard-next-packet? #f) - (subscriber (timer-expired 'rekey-timer (wild)) - (match-state conn - (on-message [(timer-expired 'rekey-timer now) - (sequence-actions (transition conn) - maybe-rekey)]))) + (define authentication-state #f) + (define channels '()) + (define is-server? (case session-role ((client) #f) ((server) #t))) - (subscriber (outbound-byte-credit (wild)) - (match-state conn - (on-message [(outbound-byte-credit amount) - (sequence-actions (transition conn) - (bump-total amount) - maybe-rekey)]))) + (at conn-ds + (during (task $seq _ (ssh-msg-disconnect $reason-code $description $language-tag)) + (at conn-ds (assert (task-accepted seq))) + (disconnect-with-error* conn-ds #t + '() + reason-code + "Received SSH_MSG_DISCONNECT with reason code ~a and message ~s" + reason-code + (bytes->string/utf-8 (bit-string->bytes description)))) - (subscriber (inbound-packet (wild) (wild) (wild) (wild)) - (match-state conn - (on-message - [(inbound-packet sequence-number payload message transfer-size) - (sequence-actions (transition conn) - (lambda (conn) - (if (connection-discard-next-packet? conn) - (transition - (struct-copy connection conn [discard-next-packet? #f])) - (dispatch-packet sequence-number payload message conn))) - (bump-total transfer-size) - (send-message (inbound-credit 1)) - maybe-rekey)]))))) + (during (task $seq _ (ssh-msg-ignore _)) + (at conn-ds (assert (task-accepted seq)))) + + (during (task $seq _ (ssh-msg-unimplemented $peer-seq)) + (at conn-ds (assert (task-accepted seq))) + (disconnect-with-error/local-info + conn-ds + `((offending-sequence-number ,peer-seq)) + SSH_DISCONNECT_PROTOCOL_ERROR + "Disconnecting because of received SSH_MSG_UNIMPLEMENTED.")) + + (during (task $seq _ ($ message (ssh-msg-debug _ _ _))) + (at conn-ds (assert (task-accepted seq))) + (log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message))) + + (during (task $seq $packet ($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _))) + (at conn-ds (assert (task-accepted seq))) + (do-kexinit conn-ds + ground-ds + #:packet packet + #:message message + #:rekey-state rekey-state + #:is-server? is-server? + #:local-id local-identification-string + #:remote-id peer-identification-string + #:session-id session-id + #:total-transferred total-transferred + #:discard-next-packet? discard-next-packet?)) + + (when (message 'enable-service-request!) + (log-info "Saw enable-service-request!") + ;; TODO:: + ;; (set-handlers + ;; (struct-copy connection conn [rekey-state new-rekey-state]) + ;; SSH_MSG_SERVICE_REQUEST handle-msg-service-request) + ) + ) + + (define (maybe-rekey) + (match (rekey-state) + [(rekey-wait deadline threshold-bytes) + (when (or (>= (current-seconds) deadline) + (>= (total-transferred) threshold-bytes)) + (define algs ((local-algorithm-list))) + (send! conn-ds (outbound-packet algs)) + (rekey-state (rekey-local algs)))] + [_ (void)])) + + (at ground-ds + (when (message (TimerExpired 'rekey-timer _)) + (maybe-rekey))) + + (at conn-ds + (when (message (outbound-byte-credit $amount)) + (total-transferred (+ (total-transferred) amount)) + (maybe-rekey)) + + (when (message (inbound-packet $sequence-number $payload $message $transfer-size)) + (if (discard-next-packet?) + (discard-next-packet? #f) + (let ((packet-type-number (bytes-ref payload 0))) + (if (and (not (rekey-wait? (rekey-state))) + (or (not (ssh-msg-type-transport-layer? packet-type-number)) + (= packet-type-number SSH_MSG_SERVICE_REQUEST) + (= packet-type-number SSH_MSG_SERVICE_ACCEPT))) + ;; We're in the middle of some phase of an active key-exchange, + ;; and received a packet that's for a higher layer than the + ;; transport layer, or one of the forbidden types given at the + ;; send of RFC4253 section 7.1. + (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR + "Packets of type ~v forbidden while in key-exchange" + packet-type-number) + ;; We're either idling, or it's a permitted packet type while + ;; performing key exchange. Look it up in the dispatch table. + (react + (at conn-ds + (assert (task sequence-number payload message)) + (stop-when (asserted (task-accepted sequence-number)))) + (sync! conn-ds + (send! conn-ds (outbound-packet (ssh-msg-unimplemented sequence-number)))))))) + (total-transferred (+ (total-transferred) transfer-size)) + (send! conn-ds (inbound-credit 1)) + (maybe-rekey)))) diff --git a/syndicate-ssh/ssh-transport.rkt b/syndicate-ssh/ssh-transport.rkt index 71e7623..2fd7985 100644 --- a/syndicate-ssh/ssh-transport.rkt +++ b/syndicate-ssh/ssh-transport.rkt @@ -1,23 +1,16 @@ -#lang racket/base +#lang syndicate ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones (require bitsyntax) -(require (planet vyzo/crypto:2:3)) - -(require racket/set) -(require racket/match) - (require rackunit) +(require syndicate/drivers/tcp) -(require "aes-ctr.rkt") - +(require "crypto.rkt") (require "ssh-numbers.rkt") (require "ssh-message-types.rkt") (require "ssh-exceptions.rkt") -(require "marketplace-support.rkt") - (provide (struct-out inbound-packet) (struct-out inbound-credit) (struct-out outbound-packet) @@ -103,56 +96,42 @@ 0 0)) -(define (make-evp-cipher-entry name cipher) +(define (make-cipher-entry name cipher-spec key-length) (list name (supported-cipher name (lambda (enc? key iv) - (let ((state ((if enc? cipher-encrypt cipher-decrypt) - cipher key iv #:padding #f))) - (lambda (block) - (cipher-update! state block)))) - (cipher-key-length cipher) - (cipher-block-size cipher) - (cipher-iv-length cipher)))) - -(define (aes-ctr-cipher-factory enc? key iv) - (let ((state (start-aes-ctr key iv))) - (lambda (block) - (aes-ctr-process! state block)))) - -(define (make-aes-ctr-entry name key-length) - (list name - (supported-cipher name - aes-ctr-cipher-factory - key-length - 16 - 16))) + (lambda (input) + ((if enc? encrypt decrypt) + cipher-spec key iv input #:pad #f))) + key-length + (cipher-block-size cipher-spec) + (cipher-iv-size cipher-spec)))) (define supported-crypto-algorithms (list - (make-aes-ctr-entry 'aes128-ctr 16) - (make-aes-ctr-entry 'aes192-ctr 24) - (make-aes-ctr-entry 'aes256-ctr 32) - (make-evp-cipher-entry 'aes128-cbc cipher:aes-128-cbc) - (make-evp-cipher-entry 'aes192-cbc cipher:aes-192-cbc) - (make-evp-cipher-entry 'aes256-cbc cipher:aes-256-cbc) - (make-evp-cipher-entry '3des-cbc cipher:des-ede3) + (make-cipher-entry 'aes128-ctr '(aes ctr) 16) + (make-cipher-entry 'aes192-ctr '(aes ctr) 24) + (make-cipher-entry 'aes256-ctr '(aes ctr) 32) + (make-cipher-entry 'aes128-cbc '(aes cbc) 16) + (make-cipher-entry 'aes192-cbc '(aes cbc) 24) + (make-cipher-entry 'aes256-cbc '(aes cbc) 32) + (make-cipher-entry '3des-cbc '(des-ede3 cbc) 24) )) ;; TODO: actually test these! -(define (make-hmac-entry name digest key-length-or-false) - (let* ((digest-length (digest-size digest)) +(define (make-hmac-entry name digest-spec key-length-or-false) + (let* ((digest-length (digest-size digest-spec)) (key-length (or key-length-or-false digest-length))) (list name (supported-hmac name (lambda (key) (lambda (blob) - (hmac digest key blob))) + (hmac digest-spec key blob))) digest-length key-length)))) (define supported-hmac-algorithms - (list (make-hmac-entry 'hmac-md5 digest:md5 #f) - (make-hmac-entry 'hmac-sha1 digest:sha1 #f))) + (list (make-hmac-entry 'hmac-md5 'md5 #f) + (make-hmac-entry 'hmac-sha1 'sha1 #f))) (define supported-compression-algorithms '(none)) ;; TODO: zlib, and zlib delayed @@ -161,7 +140,7 @@ (mac-names (map car supported-hmac-algorithms))) (make-parameter (lambda () - (ssh-msg-kexinit (random-bytes 16) + (ssh-msg-kexinit (crypto-random-bytes 16) '(diffie-hellman-group14-sha1 diffie-hellman-group1-sha1) '(ssh-dss) ;; TODO: offer ssh-rsa. This will @@ -190,7 +169,7 @@ null-hmac null-hmac-description)) -(define (apply-negotiated-options nk is-outbound?) +(define (apply-negotiated-options conn-ds nk is-outbound?) (match-define (new-keys is-server? derive-key c2s-enc s2c-enc @@ -208,7 +187,8 @@ (define cipher-description (cond ((assq enc supported-crypto-algorithms) => cadr) - (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED + (else (disconnect-with-error conn-ds + SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Could not find driver for encryption algorithm ~v" enc)))) (define cipher @@ -220,7 +200,8 @@ (define hmac-description (cond ((assq mac supported-hmac-algorithms) => cadr) - (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED + (else (disconnect-with-error conn-ds + SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Could not find driver for HMAC algorithm ~v" mac)))) (define hmac @@ -240,7 +221,7 @@ (mac (bit-string->bytes (bit-string-append (integer->bit-string sequence-number 32 #t) packet)))) -(define (check-packet-length! actual-length limit block-size) +(define (check-packet-length! conn-ds actual-length limit block-size) (when (> actual-length limit) (log-warning (format "Packet of length ~v exceeded our limit of ~v" actual-length @@ -250,7 +231,8 @@ ;; exceed the packet size limit! (For example, sending a packet of ;; length 65564 when I'm expecting a max of 65536.) So we actually ;; enforce twice our actual limit. - (disconnect-with-error 0 ;; TODO: better reason code? + (disconnect-with-error conn-ds + 0 ;; TODO: better reason code? "Packet of length ~v is longer than packet limit ~v" actual-length limit)) @@ -259,7 +241,8 @@ ;; the length-of-length, but the requirements for transmitted ;; chunks of data are that they be block-size multiples ;; *including* the length-of-length - (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR + (disconnect-with-error conn-ds + SSH_DISCONNECT_PROTOCOL_ERROR "Packet of length ~v is not a multiple of block size ~v" actual-length block-size))) @@ -279,190 +262,125 @@ ;; Encrypted Packet Input ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(struct ssh-reader-state (mode config sequence-number remaining-credit) #:prefab) - -(define (ssh-reader new-conversation) - (match-define (tcp-channel remote-addr local-addr _) new-conversation) +(define (ssh-reader conn-ds conn update-input-handler) (define packet-size-limit (default-packet-limit)) + (define sequence-number 0) + (define remaining-credit 0) - (define (issue-credit state) - (match-define (ssh-reader-state _ (crypto-configuration _ desc _ _) _ message-credit) state) - (when (positive? message-credit) - (at-meta-level - (send-feedback (tcp-channel remote-addr local-addr - (tcp-credit (supported-cipher-block-size desc))))))) + (define config initial-crypto-configuration) - (transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0) - (at-meta-level - (name-endpoint 'socket-reader - (subscriber (tcp-channel remote-addr local-addr ?) - (match-state (and state - (ssh-reader-state mode - (crypto-configuration cipher - cipher-description - hmac - hmac-description) - sequence-number - remaining-credit)) - (on-message - [(tcp-channel _ _ (? eof-object?)) - (transition state (quit))] - [(tcp-channel _ _ (? bytes? encrypted-packet)) - (let () - (define block-size (supported-cipher-block-size cipher-description)) - (define first-block-size block-size) - (define subsequent-block-size (if cipher block-size 1)) - (define decryptor (if cipher cipher values)) + (define (current-cipher) (crypto-configuration-cipher config)) + (define (block-size) + (supported-cipher-block-size (crypto-configuration-cipher-description config))) + (define (decrypt-chunk chunk) ((or (current-cipher) values) chunk)) + (define (subsequent-block-size) (if (current-cipher) (block-size) 1)) + (define (hmac) (crypto-configuration-hmac config)) - (define (check-hmac packet-length payload-length packet) - (define computed-hmac-bytes (apply-hmac hmac sequence-number packet)) - (define mac-byte-count (bytes-length computed-hmac-bytes)) - (if (positive? mac-byte-count) - (transition (struct-copy ssh-reader-state state - [mode `(packet-hmac ,computed-hmac-bytes - ,mac-byte-count - ,packet-length - ,payload-length - ,packet)]) - (at-meta-level - (send-feedback (tcp-channel remote-addr local-addr - (tcp-credit mac-byte-count))))) - (finish-packet 0 packet-length payload-length packet))) + (define (issue-credit) + (when (positive? remaining-credit) + (send-bytes-credit conn (block-size)))) - (define (finish-packet mac-byte-count packet-length payload-length packet) - (define bytes-read (+ packet-length mac-byte-count)) - (define payload (subbytes packet 5 (+ 5 payload-length))) - (define new-credit (- remaining-credit 1)) - (define new-state (struct-copy ssh-reader-state state - [mode 'packet-header] - [sequence-number (+ sequence-number 1)] - [remaining-credit new-credit])) - (transition new-state - (issue-credit new-state) - (send-message - (inbound-packet sequence-number - payload - (ssh-message-decode payload) - bytes-read)))) + (define (handle-packet-header encrypted-packet _mode) + (define first-block (decrypt-chunk encrypted-packet)) + (define packet-length (integer-bytes->integer first-block #f #t 0 4)) + (check-packet-length! conn-ds packet-length packet-size-limit (subsequent-block-size)) + (define padding-length (bytes-ref first-block 4)) + (define payload-length (- packet-length padding-length 1)) + (define amount-of-packet-in-first-block (- (bytes-length first-block) 4)) ;; not incl length + (define remaining-to-read (- packet-length amount-of-packet-in-first-block)) + (if (positive? remaining-to-read) + (begin + (send-bytes-credit conn remaining-to-read) + (update-input-handler + #:on-data (lambda (encrypted-packet _mode) + (check-hmac packet-length + payload-length + (bytes-append first-block (decrypt-chunk encrypted-packet)))))) + (check-hmac packet-length payload-length first-block))) - (match mode - ['packet-header - (define decrypted-packet (decryptor encrypted-packet)) - (define first-block decrypted-packet) - (define packet-length (integer-bytes->integer first-block #f #t 0 4)) - (check-packet-length! packet-length packet-size-limit subsequent-block-size) - (define padding-length (bytes-ref first-block 4)) - (define payload-length (- packet-length padding-length 1)) - (define amount-of-packet-in-first-block - (- (bytes-length first-block) 4)) ;; not incl length - (define remaining-to-read (- packet-length amount-of-packet-in-first-block)) + (define (check-hmac packet-length payload-length packet) + (define computed-hmac-bytes (apply-hmac (hmac) sequence-number packet)) + (define mac-byte-count (bytes-length computed-hmac-bytes)) + (if (positive? mac-byte-count) + (begin + (send-bytes-credit conn mac-byte-count) + (update-input-handler + #:on-data (lambda (received-hmac-bytes _mode) + (if (equal? computed-hmac-bytes received-hmac-bytes) + (finish-packet mac-byte-count packet-length payload-length packet) + (disconnect-with-error/local-info conn-ds + `((expected-hmac ,computed-hmac-bytes) + (actual-hmac ,received-hmac-bytes)) + SSH_DISCONNECT_MAC_ERROR + "Corrupt MAC"))))) + (finish-packet 0 packet-length payload-length packet))) - (if (positive? remaining-to-read) - (transition (struct-copy ssh-reader-state state - [mode `(packet-body ,packet-length - ,payload-length - ,first-block)]) - (at-meta-level - (send-feedback (tcp-channel remote-addr local-addr - (tcp-credit remaining-to-read))))) - (check-hmac packet-length payload-length first-block))] + (define (finish-packet mac-byte-count packet-length payload-length packet) + (define bytes-read (+ packet-length mac-byte-count)) + (define payload (subbytes packet 5 (+ 5 payload-length))) + (update-input-handler #:on-data handle-packet-header) + (send! conn-ds (inbound-packet sequence-number + payload + (ssh-message-decode payload) + bytes-read)) + (set! sequence-number (+ sequence-number 1)) + (set! remaining-credit (- remaining-credit 1)) + (issue-credit)) - [`(packet-body ,packet-length ,payload-length ,first-block) - (define decrypted-packet (decryptor encrypted-packet)) - (check-hmac packet-length payload-length (bytes-append first-block - decrypted-packet))] + (update-input-handler + #:on-eof (lambda () (stop-current-facet)) + #:on-data handle-packet-header) - [`(packet-hmac ,computed-hmac-bytes - ,mac-byte-count - ,packet-length - ,payload-length - ,main-packet) - (define received-hmac-bytes encrypted-packet) ;; not really encrypted! - (if (equal? computed-hmac-bytes received-hmac-bytes) - (finish-packet mac-byte-count packet-length payload-length main-packet) - (disconnect-with-error/local-info `((expected-hmac ,computed-hmac-bytes) - (actual-hmac ,received-hmac-bytes)) - SSH_DISCONNECT_MAC_ERROR - "Corrupt MAC"))]))]))))) - (subscriber (inbound-credit (wild)) - (match-state state - (on-message - [(inbound-credit amount) - (let () - (define new-state (struct-copy ssh-reader-state state - [remaining-credit - (+ amount (ssh-reader-state-remaining-credit state))])) - (transition new-state - (issue-credit new-state)))]))) - (subscriber (new-keys (wild) - (wild) - (wild) (wild) - (wild) (wild) - (wild) (wild)) - (match-state state - (on-message - [(? new-keys? nk) - (transition (struct-copy ssh-reader-state state - [config (apply-negotiated-options nk #f)]))]))) - (publisher (inbound-packet (wild) (wild) (wild) (wild))))) + (at conn-ds + (when (message (inbound-credit $amount)) + (set! remaining-credit (+ remaining-credit amount)) + (issue-credit)) + + (when (message ($ nk (new-keys _ _ _ _ _ _ _ _))) + (set! config (apply-negotiated-options conn-ds nk #f))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Encrypted Packet Output ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(struct ssh-writer-state (config sequence-number) #:prefab) +;; (struct ssh-writer-state (config sequence-number) #:prefab) -(define (ssh-writer new-conversation) - (match-define (tcp-channel remote-addr local-addr _) new-conversation) - (transition (ssh-writer-state initial-crypto-configuration 0) - (publisher (outbound-byte-credit (wild))) - (subscriber (outbound-packet (wild)) - (match-state (and state - (ssh-writer-state (crypto-configuration cipher - cipher-description - hmac - hmac-description) - sequence-number)) - (on-message - [(outbound-packet message) - (let () - (define pad-block-size (supported-cipher-block-size cipher-description)) - (define encryptor (if cipher cipher values)) - (define payload (ssh-message-encode message)) - ;; There must be at least 4 bytes of padding, and padding needs to - ;; make the packet length a multiple of pad-block-size. - (define unpadded-length (+ 4 ;; length of length - 1 ;; length of length-of-padding indicator - (bit-string-byte-count payload))) - (define min-padded-length (+ unpadded-length 4)) - (define padded-length (round-up min-padded-length pad-block-size)) - (define padding-length (- padded-length unpadded-length)) - (define packet-length (- padded-length 4)) - ;; ^^ the packet length does *not* include itself! - (define packet (bit-string->bytes - (bit-string (packet-length :: integer bits 32) - (padding-length :: integer bits 8) - (payload :: binary) - ((random-bytes padding-length) :: binary)))) - (define encrypted-packet (encryptor packet)) - (define computed-hmac-bytes (apply-hmac hmac sequence-number packet)) - (define mac-byte-count (bytes-length computed-hmac-bytes)) - (transition (struct-copy ssh-writer-state state - [sequence-number (+ sequence-number 1)]) - (at-meta-level - (send-message (tcp-channel local-addr remote-addr encrypted-packet))) - (when (positive? mac-byte-count) - (at-meta-level - (send-message (tcp-channel local-addr remote-addr computed-hmac-bytes)))) - (send-message - (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count)))))]))) - (subscriber (new-keys (wild) - (wild) - (wild) (wild) - (wild) (wild) - (wild) (wild)) - (match-state state - (on-message - [(? new-keys? nk) - (transition - (struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))]))))) +(define (ssh-writer conn-ds conn) + (define config initial-crypto-configuration) + (define sequence-number 0) + + (define (block-size) + (supported-cipher-block-size (crypto-configuration-cipher-description config))) + (define (encrypt-chunk chunk) ((or (crypto-configuration-cipher config) values) chunk)) + (define (hmac) (crypto-configuration-hmac config)) + + (at conn-ds + (when (message (outbound-packet $message)) + (define pad-block-size (block-size)) + (define payload (ssh-message-encode message)) + ;; There must be at least 4 bytes of padding, and padding needs to + ;; make the packet length a multiple of pad-block-size. + (define unpadded-length (+ 4 ;; length of length + 1 ;; length of length-of-padding indicator + (bit-string-byte-count payload))) + (define min-padded-length (+ unpadded-length 4)) + (define padded-length (round-up min-padded-length pad-block-size)) + (define padding-length (- padded-length unpadded-length)) + (define packet-length (- padded-length 4)) + ;; ^^ the packet length does *not* include itself! + (define packet (bit-string->bytes + (bit-string (packet-length :: integer bits 32) + (padding-length :: integer bits 8) + (payload :: binary) + ((crypto-random-bytes padding-length) :: binary)))) + (define encrypted-packet (encrypt-chunk packet)) + (define computed-hmac-bytes (apply-hmac (hmac) sequence-number packet)) + (define mac-byte-count (bytes-length computed-hmac-bytes)) + (send-data conn encrypted-packet) + (send-data conn computed-hmac-bytes) + (send! conn-ds (outbound-byte-credit (+ (bytes-length encrypted-packet) + (bytes-length computed-hmac-bytes)))) + (set! sequence-number (+ sequence-number 1))) + + (when (message ($ nk (new-keys _ _ _ _ _ _ _ _))) + (set! config (apply-negotiated-options conn-ds nk #t))))) diff --git a/syndicate-ssh/test-dsa-key b/syndicate-ssh/test-dsa-key new file mode 100644 index 0000000..94350ee --- /dev/null +++ b/syndicate-ssh/test-dsa-key @@ -0,0 +1,12 @@ +-----BEGIN DSA PRIVATE KEY----- +MIIBuwIBAAKBgQCEQ1YvOR7/MQByCPJt/FSO7NN7YO1VLqy7A95M07q6AaG5FZ2A +m9s8KZPlNFPrNhG8pRxxHhWgfBczoIObZi2saXeXQyTCUtHUejQBk+Xl31I+0SYU +/m5fIP3Q9UY3cR8LucsIQkJIcuLVpoMmtFA/EtxYs+roxm+wtMlgk/8HkQIVAObN +DEIjvgKwW9MKzRz8VXms/aDDAoGAeMnKQxj/iBSfQ3Wsd4ipCi3PdoLJ0+TJuiFG +0tmbxLxwC0YCR24YMeobva/SpSu6y48+2rjv9Wc9ZKwISbrdO6xrNgDJtoCZLGK+ +C2DHEC3rBYFicOgpoysk/HsS/to3GtMnPyA2NJDR/cjUdgWBRg+4eAx1ZsVPjaJT +A5Z60tECgYAkhzk5oi/b3zxPEPoFYki2apR4mciJso/1mYvb6fpd+rzlihNrkFAA +LL+6uOofkyf32FIQhEN+JXDNMfaHreJkLPxGXIJ4FyUbrrZcxbmgJdh9NHd0L/mI +yIHlo+SImp1DLCEtRP1GwKv8Lm0/rFNpY/z5Os3qeXKw1swDvEMfywIVANtH4mhn +F6JfX/4/cJ4cpGlcgrWe +-----END DSA PRIVATE KEY----- diff --git a/syndicate-ssh/test/test-aes-ctr.rkt b/syndicate-ssh/test/test-aes-ctr.rkt deleted file mode 100644 index 742b005..0000000 --- a/syndicate-ssh/test/test-aes-ctr.rkt +++ /dev/null @@ -1,138 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones - -(require "../aes-ctr.rkt") -(require rackunit) -(require bitsyntax) - -(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0)))) - (aes-ctr-process! x #"abcdefghijklmnop")) - #"\275XO-\317^bytes str) ;; grumble - (define cleaned (regexp-replace* #rx"[^0-9a-fA-F]+" str "")) - (define bits (* (string-length cleaned) 4)) - (define n (string->number cleaned 16)) - (integer->bit-string n bits #t)) - -(define (test-enc description key ivec plaintext ciphertext) - (let ((state (start-aes-ctr (hex-string->bytes key) - (hex-string->bytes ivec)))) - (check-equal? (aes-ctr-process! state (hex-string->bytes plaintext)) - (hex-string->bytes ciphertext) - (format "test-enc ~v" description)))) - -;; Test Vector #1: Encrypting 16 octets using AES-CTR with 128-bit key -(test-enc 1 - "AE 68 52 F8 12 10 67 CC 4B F7 A5 76 55 77 F3 9E" - "00 00 00 30 00 00 00 00 00 00 00 00 00 00 00 01" - "53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67" - "E4 09 5D 4F B7 A7 B3 79 2D 61 75 A3 26 13 11 B8") - -;; Test Vector #2: Encrypting 32 octets using AES-CTR with 128-bit key -(test-enc 2 - "7E 24 06 78 17 FA E0 D7 43 D6 CE 1F 32 53 91 63" - "00 6C B6 DB C0 54 3B 59 DA 48 D9 0B 00 00 00 01" - (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F" - "10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F") - (string-append "51 04 A1 06 16 8A 72 D9 79 0D 41 EE 8E DA D3 88" - "EB 2E 1E FC 46 DA 57 C8 FC E6 30 DF 91 41 BE 28")) - -;; Test Vector #3: Encrypting 36 octets using AES-CTR with 128-bit key -(test-enc 3 - "76 91 BE 03 5E 50 20 A8 AC 6E 61 85 29 F9 A0 DC" - "00 E0 01 7B 27 77 7F 3F 4A 17 86 F0 00 00 00 01" - (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F" - "10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F" - "20 21 22 23") - (string-append "C1 CF 48 A8 9F 2F FD D9 CF 46 52 E9 EF DB 72 D7" - "45 40 A4 2B DE 6D 78 36 D5 9A 5C EA AE F3 10 53" - "25 B2 07 2F")) - -;; Test Vector #4: Encrypting 16 octets using AES-CTR with 192-bit key -(test-enc 4 - "16 AF 5B 14 5F C9 F5 79 C1 75 F9 3E 3B FB 0E ED 86 3D 06 CC FD B7 85 15" - "00 00 00 48 36 73 3C 14 7D 6D 93 CB 00 00 00 01" - "53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67" - "4B 55 38 4F E2 59 C9 C8 4E 79 35 A0 03 CB E9 28") - -;; Test Vector #5: Encrypting 32 octets using AES-CTR with 192-bit key -(test-enc 5 - "7C 5C B2 40 1B 3D C3 3C 19 E7 34 08 19 E0 F6 9C 67 8C 3D B8 E6 F6 A9 1A" - "00 96 B0 3B 02 0C 6E AD C2 CB 50 0D 00 00 00 01" - (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F" - "10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F") - (string-append "45 32 43 FC 60 9B 23 32 7E DF AA FA 71 31 CD 9F" - "84 90 70 1C 5A D4 A7 9C FC 1F E0 FF 42 F4 FB 00")) - -;; Test Vector #6: Encrypting 36 octets using AES-CTR with 192-bit key -(test-enc 6 - "02 BF 39 1E E8 EC B1 59 B9 59 61 7B 09 65 27 9B F5 9B 60 A7 86 D3 E0 FE" - "00 07 BD FD 5C BD 60 27 8D CC 09 12 00 00 00 01" - (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F" - "10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F" - "20 21 22 23") - (string-append "96 89 3F C5 5E 5C 72 2F 54 0B 7D D1 DD F7 E7 58" - "D2 88 BC 95 C6 91 65 88 45 36 C8 11 66 2F 21 88" - "AB EE 09 35")) - -;; Test Vector #7: Encrypting 16 octets using AES-CTR with 256-bit key -(test-enc 7 - (string-append "77 6B EF F2 85 1D B0 6F 4C 8A 05 42 C8 69 6F 6C" - "6A 81 AF 1E EC 96 B4 D3 7F C1 D6 89 E6 C1 C1 04") - "00 00 00 60 DB 56 72 C9 7A A8 F0 B2 00 00 00 01" - "53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67" - "14 5A D0 1D BF 82 4E C7 56 08 63 DC 71 E3 E0 C0") - -;; Test Vector #8: Encrypting 32 octets using AES-CTR with 256-bit key -(test-enc 8 - (string-append "F6 D6 6D 6B D5 2D 59 BB 07 96 36 58 79 EF F8 86" - "C6 6D D5 1A 5B 6A 99 74 4B 50 59 0C 87 A2 38 84") - "00 FA AC 24 C1 58 5E F1 5A 43 D8 75 00 00 00 01" - (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F" - "10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F") - (string-append "F0 5E 23 1B 38 94 61 2C 49 EE 00 0B 80 4E B2 A9" - "B8 30 6B 50 8F 83 9D 6A 55 30 83 1D 93 44 AF 1C")) - -;; Test Vector #9: Encrypting 36 octets using AES-CTR with 256-bit key -(test-enc 9 - (string-append "FF 7A 61 7C E6 91 48 E4 F1 72 6E 2F 43 58 1D E2" - "AA 62 D9 F8 05 53 2E DF F1 EE D6 87 FB 54 15 3D") - "00 1C C5 B7 51 A5 1D 70 A1 C1 11 48 00 00 00 01" - (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F" - "10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F" - "20 21 22 23") - (string-append "EB 6C 52 82 1D 0B BB F7 CE 75 94 46 2A CA 4F AA" - "B4 07 DF 86 65 69 FD 07 F4 8C C0 B5 83 D6 07 1F" - "1E C0 E6 B8"))