diff --git a/syndicate-ssh/info.rkt b/syndicate-ssh/info.rkt index 822ed52..7f99f1d 100644 --- a/syndicate-ssh/info.rkt +++ b/syndicate-ssh/info.rkt @@ -9,10 +9,13 @@ "base" "bitsyntax" - "crypto" + "crypto-lib" "preserves" "syndicate" + "unix-socket-lib" + "sandbox-lib" + )) (define build-deps '("rackunit-lib")) diff --git a/syndicate-ssh/new-server.rkt b/syndicate-ssh/new-server.rkt index 414f9b2..11df51a 100644 --- a/syndicate-ssh/new-server.rkt +++ b/syndicate-ssh/new-server.rkt @@ -20,14 +20,13 @@ (require "ssh-exceptions.rkt") (module+ main - (actor-system/dataspace (ds) - (spawn-timer-driver ds) - (spawn-tcp-driver ds) - (spawn #:name 'ssh-tcp-listener - (at ds - (during/spawn (StreamConnection $source $sink (TcpLocal "0.0.0.0" 29418)) - #:name (list 'ssh source) - (session ds source sink)))))) + (standard-actor-system (ds) + (define spec (TcpLocal "0.0.0.0" 29418)) + (at ds + (stop-on (asserted (TcpListenError spec $message))) + (during/spawn (StreamConnection $source $sink spec) + #:name (list 'ssh source) + (session ds source sink))))) ;;--------------------------------------------------------------------------- @@ -78,8 +77,8 @@ ;; 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)) + (stop-on (asserted (Observe (:pattern (inbound-credit ,_)) _)) + (send! (inbound-credit 1)) (spawn #:name 'session @@ -95,16 +94,15 @@ ;; ;; (during $m ;; ;; (on-start (log-info "++ ~v" m)) ;; ;; (on-stop (log-info "-- ~v" m))) - ;; (when (message $m) + ;; (on (message $m) ;; (log-info ">> ~v" m))) (at conn-ds - (when (asserted (protocol-error $reason-code $message _ $originated-at-peer?)) + (on (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) - #"")))) + (send! (outbound-packet (ssh-msg-disconnect reason-code + (string->bytes/utf-8 message) + #"")))) (sync! conn-ds (stop-actor-system)))))])) (void)) diff --git a/syndicate-ssh/private/install.rkt b/syndicate-ssh/private/install.rkt index 3dcff21..0be781d 100644 --- a/syndicate-ssh/private/install.rkt +++ b/syndicate-ssh/private/install.rkt @@ -15,11 +15,10 @@ (define (pre-installer _collects-path package-path) (define output-directory (build-path package-path "schemas/gen")) (delete-directory/files output-directory #:must-exist? #f) - (parameterize ((schema-compiler-plugin-mode 'meta)) - (batch-compile #:inputs (list (build-path package-path "schemas/**.prs")) - #:additional-modules (hash '(EntityRef) 'syndicate/entity-ref) - #:output-directory output-directory - #:plugins (list schema-compiler-plugin)))) + (batch-compile #:inputs (list (build-path package-path "schemas/**.prs")) + #:additional-modules (hash '(EntityRef) 'syndicate/entity-ref) + #:output-directory output-directory + #:plugins (list schema-compiler-plugin))) (define-runtime-path package-path "..") (define (regenerate!) diff --git a/syndicate-ssh/schemas/channel.prs b/syndicate-ssh/schemas/channel.prs new file mode 100644 index 0000000..8a426f1 --- /dev/null +++ b/syndicate-ssh/schemas/channel.prs @@ -0,0 +1,3 @@ +version 1 . +embeddedType EntityRef.Ref . + diff --git a/syndicate-ssh/ssh-host-key.rkt b/syndicate-ssh/ssh-host-key.rkt index ed8014b..0f83e91 100644 --- a/syndicate-ssh/ssh-host-key.rkt +++ b/syndicate-ssh/ssh-host-key.rkt @@ -11,7 +11,7 @@ (require "keys/ssh-keys.rkt") (require "ssh-message-types.rkt") -(require rackunit) +(module+ test (require rackunit)) (provide (struct-out ed25519-private-key) (struct-out ed25519-public-key) @@ -94,6 +94,7 @@ (define host-key-ed25519-private (load-private-key "test-host-keys/ssh_host_ed25519_key")) (define host-key-ed25519-public (pk-key->public-only-key host-key-ed25519-private)) -(check-equal? (pk-key->datum (pieces->public-key (public-key->pieces host-key-ed25519-public)) - 'SubjectPublicKeyInfo) - (pk-key->datum host-key-ed25519-private 'SubjectPublicKeyInfo)) +(module+ test + (check-equal? (pk-key->datum (pieces->public-key (public-key->pieces host-key-ed25519-public)) + 'SubjectPublicKeyInfo) + (pk-key->datum host-key-ed25519-private 'SubjectPublicKeyInfo))) diff --git a/syndicate-ssh/ssh-message-types.rkt b/syndicate-ssh/ssh-message-types.rkt index f3cc885..f5453a4 100644 --- a/syndicate-ssh/ssh-message-types.rkt +++ b/syndicate-ssh/ssh-message-types.rkt @@ -2,17 +2,6 @@ ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones -(require "ssh-numbers.rkt") - -(require (for-syntax racket/base)) -(require (for-syntax (only-in racket/list append*))) -(require (for-syntax (only-in srfi/1 iota))) - -(require bitsyntax) -(require racket/bytes) - -(require rackunit) - (provide ssh-message-decode ssh-message-encode) @@ -53,6 +42,16 @@ (struct-out ssh-msg-channel-failure) ) +(require "ssh-numbers.rkt") + +(require (for-syntax racket/base)) +(require (for-syntax (only-in racket/list append*))) + +(require bitsyntax) +(require racket/bytes) + +(module+ test (require rackunit)) + (define encoder-map (make-hasheqv)) (define decoder-map (make-hasheqv)) @@ -167,7 +166,7 @@ (else (kf))))])) (define-for-syntax (codec-options field-type) - (syntax-case field-type (byte boolean uint32 uint64 string mpint name-list) + (syntax-case field-type (byte boolean uint32 uint64 string mpint name-list extension) (byte #'(integer bits 8)) ((byte n) #'((t:packed-bytes n))) (boolean #'((t:boolean))) @@ -185,11 +184,9 @@ #`(lambda (message) (let ((vec (struct->vector message))) #,(with-syntax (((field-spec ...) - (let ((type-list (syntax->list #'(field-type ...)))) - (map (lambda (index type) - #`((vector-ref vec #,index) :: #,@(codec-options type))) - (iota (length type-list) 1) - type-list)))) + (for/list [(index (in-naturals 1)) + (type (in-list (syntax->list #'(field-type ...))))] + #`((vector-ref vec #,index) :: #,@(codec-options type))))) #'(bit-string (type-byte-value :: integer bytes 1) field-spec ...)))))))) @@ -210,16 +207,17 @@ 0 (+ 1 (quotient (integer-length n) 8)))) -(check-eqv? (mpint-width 0) 0) -(check-eqv? (mpint-width #x9a378f9b2e332a7) 8) -(check-eqv? (mpint-width #x7f) 1) -(check-eqv? (mpint-width #x80) 2) -(check-eqv? (mpint-width #x81) 2) -(check-eqv? (mpint-width #xff) 2) -(check-eqv? (mpint-width #x100) 2) -(check-eqv? (mpint-width #x101) 2) -(check-eqv? (mpint-width #x-1234) 2) -(check-eqv? (mpint-width #x-deadbeef) 5) +(module+ test + (check-eqv? (mpint-width 0) 0) + (check-eqv? (mpint-width #x9a378f9b2e332a7) 8) + (check-eqv? (mpint-width #x7f) 1) + (check-eqv? (mpint-width #x80) 2) + (check-eqv? (mpint-width #x81) 2) + (check-eqv? (mpint-width #xff) 2) + (check-eqv? (mpint-width #x100) 2) + (check-eqv? (mpint-width #x101) 2) + (check-eqv? (mpint-width #x-1234) 2) + (check-eqv? (mpint-width #x-deadbeef) 5)) (define (symbols->name-list syms) (bytes-join (map (lambda (s) (string->bytes/utf-8 (symbol->string s))) syms) #",")) @@ -229,29 +227,30 @@ '() (map string->symbol (regexp-split #rx"," (bytes->string/utf-8 (bit-string->bytes bs)))))) -(struct test-message (value) #:prefab) -(let ((test-decode (compute-ssh-message-decoder test-message 123 mpint)) - (test-encode (compute-ssh-message-encoder 123 mpint))) - (define (bidi-check msg enc-without-type-tag) - (let ((enc (bytes-append (bytes 123) enc-without-type-tag))) - (let ((msg-enc (bit-string->bytes (test-encode msg))) - (enc-msg (test-decode enc))) - (if (and (equal? msg-enc enc) - (equal? enc-msg msg)) - 'ok - `(fail ,msg-enc ,enc-msg))))) - (check-eqv? (bidi-check (test-message 0) (bytes 0 0 0 0)) 'ok) - (check-eqv? (bidi-check (test-message #x9a378f9b2e332a7) - (bytes #x00 #x00 #x00 #x08 - #x09 #xa3 #x78 #xf9 - #xb2 #xe3 #x32 #xa7)) 'ok) - (check-eqv? (bidi-check (test-message #x80) - (bytes #x00 #x00 #x00 #x02 #x00 #x80)) 'ok) - (check-eqv? (bidi-check (test-message #x-1234) - (bytes #x00 #x00 #x00 #x02 #xed #xcc)) 'ok) - (check-eqv? (bidi-check (test-message #x-deadbeef) - (bytes #x00 #x00 #x00 #x05 - #xff #x21 #x52 #x41 #x11)) 'ok)) +(module+ test + (struct test-message (value) #:prefab) + (let ((test-decode (compute-ssh-message-decoder test-message 123 mpint)) + (test-encode (compute-ssh-message-encoder 123 mpint))) + (define (bidi-check msg enc-without-type-tag) + (let ((enc (bytes-append (bytes 123) enc-without-type-tag))) + (let ((msg-enc (bit-string->bytes (test-encode msg))) + (enc-msg (test-decode enc))) + (if (and (equal? msg-enc enc) + (equal? enc-msg msg)) + 'ok + `(fail ,msg-enc ,enc-msg))))) + (check-eqv? (bidi-check (test-message 0) (bytes 0 0 0 0)) 'ok) + (check-eqv? (bidi-check (test-message #x9a378f9b2e332a7) + (bytes #x00 #x00 #x00 #x08 + #x09 #xa3 #x78 #xf9 + #xb2 #xe3 #x32 #xa7)) 'ok) + (check-eqv? (bidi-check (test-message #x80) + (bytes #x00 #x00 #x00 #x02 #x00 #x80)) 'ok) + (check-eqv? (bidi-check (test-message #x-1234) + (bytes #x00 #x00 #x00 #x02 #xed #xcc)) 'ok) + (check-eqv? (bidi-check (test-message #x-deadbeef) + (bytes #x00 #x00 #x00 #x05 + #xff #x21 #x52 #x41 #x11)) 'ok))) (define-ssh-message-type ssh-msg-kexinit SSH_MSG_KEXINIT ((byte 16) cookie) diff --git a/syndicate-ssh/ssh-session.rkt b/syndicate-ssh/ssh-session.rkt index c18cc03..f81ce8e 100644 --- a/syndicate-ssh/ssh-session.rkt +++ b/syndicate-ssh/ssh-session.rkt @@ -69,30 +69,29 @@ (struct task (seq packet-type packet message) #:prefab) (struct task-complete (seq) #:prefab) -(define-event-expander with-incoming-task +(define-syntax with-incoming-task (syntax-rules () [(_ (seq-id type-byte packet-pattern message-pattern) body ...) - (with-incoming-task* when (seq-id type-byte packet-pattern message-pattern) body ...)])) + (with-incoming-task* on (seq-id type-byte packet-pattern message-pattern) body ...)])) (define-syntax-rule - (with-incoming-task/react conn-ds (seq-id type-byte packet-pattern message-pattern) body ...) + (with-incoming-task/react (seq-id type-byte packet-pattern message-pattern) body ...) (react - (at conn-ds - (with-incoming-task* stop-when (seq-id type-byte packet-pattern message-pattern) - body ...)))) + (with-incoming-task* stop-on (seq-id type-byte packet-pattern message-pattern) + body ...))) -(define-event-expander with-incoming-task* +(define-syntax with-incoming-task* (syntax-rules () - [(_ when-stx (seq-id type-byte packet-pattern message-pattern) body ...) - (when-stx (message (task ($ seq-id _) type-byte packet-pattern message-pattern)) - body ... - (send! this-target (task-complete seq-id)))])) + [(_ on-stx (seq-id type-byte packet-pattern message-pattern) body ...) + (on-stx (message (task ($ seq-id _) type-byte packet-pattern message-pattern)) + body ... + (send! (task-complete seq-id)))])) (define-syntax-rule (with-assertion-presence ds assertion #:on-present [body-present ...] #:on-absent [body-absent ...]) (let ((assertion-present #f)) - (at ds (when (asserted assertion) + (at ds (on (asserted assertion) (set! assertion-present #t) body-present ...)) (sync! ds (when (not assertion-present) @@ -150,24 +149,25 @@ (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)) - (with-incoming-task/react conn-ds (seq SSH_MSG_KEXDH_INIT _ (ssh-msg-kexdh-init $e)) - (define peer-key (datum->pk-key (list 'dh 'public p g e) 'rkt-public)) - (define shared-secret (pk-derive-secret private-key peer-key)) - (define hash-alg sha256) - (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-alg - 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))] + (at conn-ds + (with-incoming-task/react (seq SSH_MSG_KEXDH_INIT _ (ssh-msg-kexdh-init $e)) + (define peer-key (datum->pk-key (list 'dh 'public p g e) 'rkt-public)) + (define shared-secret (pk-derive-secret private-key peer-key)) + (define hash-alg sha256) + (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-alg + 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! (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)])) @@ -180,21 +180,22 @@ (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))) - (with-incoming-task/react conn-ds (seq SSH_MSG_KEXDH_REPLY _ - (ssh-msg-kexdh-reply $host-key-bytes $f $h-signature)) - (define peer-key (datum->pk-key (list 'dh 'public p g f) 'rkt-public)) - (define shared-secret (pk-derive-secret private-key peer-key)) - (define hash-alg sha256) - (define host-public-key (pieces->public-key (ssh-host-key->pieces host-key-bytes))) - (define exchange-hash (dh-exchange-hash hash-alg - 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))] + (at conn-ds + (send! (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))) + (with-incoming-task/react (seq SSH_MSG_KEXDH_REPLY _ + (ssh-msg-kexdh-reply $host-key-bytes $f $h-signature)) + (define peer-key (datum->pk-key (list 'dh 'public p g f) 'rkt-public)) + (define shared-secret (pk-derive-secret private-key peer-key)) + (define hash-alg sha256) + (define host-public-key (pieces->public-key (ssh-host-key->pieces host-key-bytes))) + (define exchange-hash (dh-exchange-hash hash-alg + 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)])) @@ -288,23 +289,24 @@ (extend (bytes-append key (hash-alg (bit-string->bytes (bit-string (k-h-prefix :: binary) (key :: binary)))))))))) - (with-incoming-task/react conn-ds (seq SSH_MSG_NEWKEYS _ (ssh-msg-newkeys)) - ;; 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-handler) - (send! conn-ds (outbound-packet (ssh-msg-newkeys))) - (send! conn-ds (new-keys is-server? - (embedded 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))))))) + (at conn-ds + (with-incoming-task/react (seq SSH_MSG_NEWKEYS _ (ssh-msg-newkeys)) + ;; 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! 'enable-service-request-handler) + (send! (outbound-packet (ssh-msg-newkeys))) + (send! (new-keys is-server? + (embedded 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 and user authentication @@ -324,25 +326,25 @@ (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE "Repeated authentication is not permitted")] [else - (send! conn-ds (outbound-packet (ssh-msg-service-accept service))) - (with-incoming-task/react conn-ds - (seq SSH_MSG_USERAUTH_REQUEST _ - (ssh-msg-userauth-request $user-name $service-name _ _)) - (cond - [(and (positive? (bytes-length user-name)) - (equal? service-name #"ssh-connection")) - ;; TODO: Actually implement client authentication - (send! conn-ds (outbound-packet (ssh-msg-userauth-success))) - (authentication-state (authenticated user-name service-name)) - (react - (at conn-ds + (at conn-ds + (send! (outbound-packet (ssh-msg-service-accept service))) + (with-incoming-task/react + (seq SSH_MSG_USERAUTH_REQUEST _ + (ssh-msg-userauth-request $user-name $service-name _ _)) + (cond + [(and (positive? (bytes-length user-name)) + (equal? service-name #"ssh-connection")) + ;; TODO: Actually implement client authentication + (send! (outbound-packet (ssh-msg-userauth-success))) + (authentication-state (authenticated user-name service-name)) + (react (with-incoming-task (seq SSH_MSG_USERAUTH_REQUEST _ _) ;; RFC4252 section 5.1 page 6 - ))) - (let ((a (authentication-state))) - (spawn #:name 'connection-service (start-connection-service conn-ds a)))] - [else - (send! conn-ds (outbound-packet (ssh-msg-userauth-failure '(none) #f)))]))])] + )) + (let ((a (authentication-state))) + (spawn #:name 'connection-service (start-connection-service conn-ds a)))] + [else + (send! (outbound-packet (ssh-msg-userauth-failure '(none) #f)))])))])] [_ (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE "Service ~v not supported" @@ -571,9 +573,9 @@ ;; $initial-window-size ;; $maximum-packet-size ;; $extra-request-data)) + ;; ( ;; (react - ;; (at conn-ds - ;; (when (asserted (Observe (:pattern ( + ;; (on (asserted (Observe (:pattern ( ;; (sync! conn-ds ;; ( ;; (when (memf (lambda (c) (equal? (ssh-channel-remote-ref c) remote-ref)) @@ -736,7 +738,7 @@ (react (at conn-ds - (stop-when (message 'enable-service-request-handler) + (stop-on (message 'enable-service-request-handler) (spawn #:name 'service-request-handler (service-request-handler conn-ds))))) (define (maybe-rekey) @@ -750,18 +752,18 @@ [_ (void)])) (at ground-ds - (when (message (TimerExpired 'rekey-timer _)) + (on (message (TimerExpired 'rekey-timer _)) (maybe-rekey))) (at conn-ds - (when (message (outbound-byte-credit $amount)) + (on (message (outbound-byte-credit $amount)) (total-transferred (+ (total-transferred) amount)) (maybe-rekey)) - (when (message (inbound-packet $sequence-number $payload $message $transfer-size)) + (on (message (inbound-packet $sequence-number $payload $message $transfer-size)) (if (discard-next-packet?) (begin (discard-next-packet? #f) - (send! conn-ds (inbound-credit 1))) + (send! (inbound-credit 1))) (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)) @@ -777,14 +779,13 @@ ;; We're either idling, or it's a permitted packet type while ;; performing key exchange. Dispatch it. (react - (on-start - (send! conn-ds (task sequence-number packet-type-number payload message))) + (on-start (send! (task sequence-number packet-type-number payload message))) (with-assertion-presence conn-ds (Observe (:pattern (task ,_ packet-type-number ,_ ,_)) _) #:on-present [] - #:on-absent [(send! conn-ds (outbound-packet (ssh-msg-unimplemented sequence-number))) - (send! conn-ds (task-complete sequence-number))]) - (at conn-ds (stop-when (message (task-complete sequence-number)))) - (on-stop (send! conn-ds (inbound-credit 1))))))) + #:on-absent [(send! (outbound-packet (ssh-msg-unimplemented sequence-number))) + (send! (task-complete sequence-number))]) + (stop-on (message (task-complete sequence-number))) + (on-stop (send! (inbound-credit 1))))))) (total-transferred (+ (total-transferred) transfer-size)) (maybe-rekey)))) diff --git a/syndicate-ssh/ssh-transport.rkt b/syndicate-ssh/ssh-transport.rkt index 88e3ae0..e278fc2 100644 --- a/syndicate-ssh/ssh-transport.rkt +++ b/syndicate-ssh/ssh-transport.rkt @@ -2,15 +2,6 @@ ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones -(require bitsyntax) -(require rackunit) -(require syndicate/drivers/tcp) - -(require "crypto.rkt") -(require "ssh-numbers.rkt") -(require "ssh-message-types.rkt") -(require "ssh-exceptions.rkt") - (provide (struct-out inbound-packet) (struct-out inbound-credit) (struct-out outbound-packet) @@ -23,6 +14,16 @@ ssh-reader ssh-writer) +(require bitsyntax) +(require syndicate/drivers/tcp) + +(require "crypto.rkt") +(require "ssh-numbers.rkt") +(require "ssh-message-types.rkt") +(require "ssh-exceptions.rkt") + +(module+ test (require rackunit)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Data definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -248,11 +249,12 @@ (define (round-up what to) (* to (quotient (+ what (- to 1)) to))) -(check-equal? (round-up 0 8) 0) -(check-equal? (round-up 1 8) 8) -(check-equal? (round-up 7 8) 8) -(check-equal? (round-up 8 8) 8) -(check-equal? (round-up 9 8) 16) +(module+ test + (check-equal? (round-up 0 8) 0) + (check-equal? (round-up 1 8) 8) + (check-equal? (round-up 7 8) 8) + (check-equal? (round-up 8 8) 8) + (check-equal? (round-up 9 8) 16)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Encrypted Packet Input @@ -332,11 +334,11 @@ (update-input-handler #:on-data handle-packet-header) (at conn-ds - (when (message (inbound-credit $amount)) + (on (message (inbound-credit $amount)) (set! remaining-credit (+ remaining-credit amount)) (issue-credit)) - (when (message ($ nk (new-keys _ _ _ _ _ _ _ _))) + (on (message ($ nk (new-keys _ _ _ _ _ _ _ _))) (set! config (apply-negotiated-options conn-ds nk #f))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -357,7 +359,7 @@ (define (hmac) (crypto-configuration-hmac config)) (at conn-ds - (when (message (outbound-packet $message)) + (on (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 @@ -380,9 +382,9 @@ (define mac-byte-count (bytes-length computed-hmac-bytes)) (send-data sink encrypted-packet) (send-data sink computed-hmac-bytes) - (send! conn-ds (outbound-byte-credit (+ (bytes-length encrypted-packet) - (bytes-length computed-hmac-bytes)))) + (send! (outbound-byte-credit (+ (bytes-length encrypted-packet) + (bytes-length computed-hmac-bytes)))) (set! sequence-number (+ sequence-number 1))) - (when (message ($ nk (new-keys _ _ _ _ _ _ _ _))) + (on (message ($ nk (new-keys _ _ _ _ _ _ _ _))) (set! config (apply-negotiated-options conn-ds nk #t))))) diff --git a/syndicate-ssh/test/test-asn1-ber.rkt b/syndicate-ssh/test/test-asn1-ber.rkt index 6dbf160..dc08ca7 100644 --- a/syndicate-ssh/test/test-asn1-ber.rkt +++ b/syndicate-ssh/test/test-asn1-ber.rkt @@ -2,43 +2,44 @@ ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones -(require rackunit) -(require "../asn1-ber.rkt") +(module+ test + (require rackunit) + (require "../asn1-ber.rkt") -(require bitsyntax) + (require bitsyntax) -(define dsa-key - #"0\201\336\2@\v\336jE\275\310\266\313y\365\307\e\243\304p\b8l=\3419\227\262\340E\253\333\263%X<\0235\374\30b \367\244\306\253/\22\213b\27\333\203Q\376zS\1\fS\312[\2553\rj\252C-\2A\0\207\26gPqe\245\3632:\5\317\345w\373\v8\231g\3155\376\270\256\f\250c\271\253\2\276\32\365\246\f\265\243\220\36\0302\349\3wI\vZ$I\320\374f\235KX\37\361\235\333\335\236\326\301\2\25\0\215rI\353\212\275\360\222c\365\r\310Z~E\327\337\30\344e\2@.F\2726\24w\352\352%\213~O\2Y\352\246`\246\243\fi\3\v\262\311w\0\211\241.\35\20\377\207F\321\375\354\347\336z3*\241N\347CT\254W98\311'&\204E\277\220\241\343\23sG") + (define dsa-key + #"0\201\336\2@\v\336jE\275\310\266\313y\365\307\e\243\304p\b8l=\3419\227\262\340E\253\333\263%X<\0235\374\30b \367\244\306\253/\22\213b\27\333\203Q\376zS\1\fS\312[\2553\rj\252C-\2A\0\207\26gPqe\245\3632:\5\317\345w\373\v8\231g\3155\376\270\256\f\250c\271\253\2\276\32\365\246\f\265\243\220\36\0302\349\3wI\vZ$I\320\374f\235KX\37\361\235\333\335\236\326\301\2\25\0\215rI\353\212\275\360\222c\365\r\310Z~E\327\337\30\344e\2@.F\2726\24w\352\352%\213~O\2Y\352\246`\246\243\fi\3\v\262\311w\0\211\241.\35\20\377\207F\321\375\354\347\336z3*\241N\347CT\254W98\311'&\204E\277\220\241\343\23sG") -;; #"3081de02400bde6a45bdc8b6cb79f5c71ba3c47008386c3de13997b2e045abdbb325583c1335fc186220f7a4c6ab2f128b6217db8351fe7a53010c53ca5bad330d6aaa432d024100871667507165a5f3323a05cfe577fb0b389967cd35feb8ae0ca863b9ab02be1af5a60cb5a3901e18321c390377490b5a2449d0fc669d4b581ff19ddbdd9ed6c10215008d7249eb8abdf09263f50dc85a7e45d7df18e46502402e46ba361477eaea258b7e4f0259eaa660a6a30c69030bb2c9770089a12e1d10ff8746d1fdece7de7a332aa14ee74354ac573938c927268445bf90a1e3137347" + ;; #"3081de02400bde6a45bdc8b6cb79f5c71ba3c47008386c3de13997b2e045abdbb325583c1335fc186220f7a4c6ab2f128b6217db8351fe7a53010c53ca5bad330d6aaa432d024100871667507165a5f3323a05cfe577fb0b389967cd35feb8ae0ca863b9ab02be1af5a60cb5a3901e18321c390377490b5a2449d0fc669d4b581ff19ddbdd9ed6c10215008d7249eb8abdf09263f50dc85a7e45d7df18e46502402e46ba361477eaea258b7e4f0259eaa660a6a30c69030bb2c9770089a12e1d10ff8746d1fdece7de7a332aa14ee74354ac573938c927268445bf90a1e3137347" -(define rsa-key - #"0H\2A\0\257\247\361\314Jm\317w\325OD\223\263\353h\356\300\211Y\16x\344\361\314N\251\t\26\1S\362\222\205,ifN\374\321\230\355\363L\351\311M\255\335\301W\203\177;[\177\272\357\"p\nl\315\216\5\2\3\1\0\1") + (define rsa-key + #"0H\2A\0\257\247\361\314Jm\317w\325OD\223\263\353h\356\300\211Y\16x\344\361\314N\251\t\26\1S\362\222\205,ifN\374\321\230\355\363L\351\311M\255\335\301W\203\177;[\177\272\357\"p\nl\315\216\5\2\3\1\0\1") -;; #"3048024100afa7f1cc4a6dcf77d54f4493b3eb68eec089590e78e4f1cc4ea909160153f292852c69664efcd198edf34ce9c94dadddc157837f3b5b7fbaef22700a6ccd8e050203010001" + ;; #"3048024100afa7f1cc4a6dcf77d54f4493b3eb68eec089590e78e4f1cc4ea909160153f292852c69664efcd198edf34ce9c94dadddc157837f3b5b7fbaef22700a6ccd8e050203010001" -(check-equal? (bit-string (123 :: (t:long-ber-tag))) (bytes 123)) -(check-equal? (bit-string (234 :: (t:long-ber-tag))) (bytes 129 106)) -(check-equal? (bit-string (12345678 :: (t:long-ber-tag))) (bytes 133 241 194 78)) + (check-equal? (bit-string (123 :: (t:long-ber-tag))) (bytes 123)) + (check-equal? (bit-string (234 :: (t:long-ber-tag))) (bytes 129 106)) + (check-equal? (bit-string (12345678 :: (t:long-ber-tag))) (bytes 133 241 194 78)) -(check-equal? (bit-string-case (bytes 123) ([(v :: (t:long-ber-tag))] v)) 123) -(check-equal? (bit-string-case (bytes 129 106) ([(v :: (t:long-ber-tag))] v)) 234) -(check-equal? (bit-string-case (bytes 133 241 194 78) ([(v :: (t:long-ber-tag))] v)) 12345678) + (check-equal? (bit-string-case (bytes 123) ([(v :: (t:long-ber-tag))] v)) 123) + (check-equal? (bit-string-case (bytes 129 106) ([(v :: (t:long-ber-tag))] v)) 234) + (check-equal? (bit-string-case (bytes 133 241 194 78) ([(v :: (t:long-ber-tag))] v)) 12345678) -(check-equal? (bit-string->bytes (bit-string (12 :: (t:ber-length-indicator)))) - (bytes 12)) -(check-equal? (bit-string->bytes (bit-string (123 :: (t:ber-length-indicator)))) - (bytes 123)) -(check-equal? (bit-string->bytes (bit-string (1234 :: (t:ber-length-indicator)))) - (bytes 130 4 210)) -(check-equal? (bit-string->bytes (bit-string (12345678 :: (t:ber-length-indicator)))) - (bytes 131 188 97 78)) + (check-equal? (bit-string->bytes (bit-string (12 :: (t:ber-length-indicator)))) + (bytes 12)) + (check-equal? (bit-string->bytes (bit-string (123 :: (t:ber-length-indicator)))) + (bytes 123)) + (check-equal? (bit-string->bytes (bit-string (1234 :: (t:ber-length-indicator)))) + (bytes 130 4 210)) + (check-equal? (bit-string->bytes (bit-string (12345678 :: (t:ber-length-indicator)))) + (bytes 131 188 97 78)) -(check-equal? (bit-string-case (bytes 12) ([(v :: (t:ber-length-indicator))] v)) 12) -(check-equal? (bit-string-case (bytes 123) ([(v :: (t:ber-length-indicator))] v)) 123) -(check-equal? (bit-string-case (bytes 130 4 210) ([(v :: (t:ber-length-indicator))] v)) 1234) -(check-equal? (bit-string-case (bytes 131 188 97 78) ([(v :: (t:ber-length-indicator))] v)) - 12345678) + (check-equal? (bit-string-case (bytes 12) ([(v :: (t:ber-length-indicator))] v)) 12) + (check-equal? (bit-string-case (bytes 123) ([(v :: (t:ber-length-indicator))] v)) 123) + (check-equal? (bit-string-case (bytes 130 4 210) ([(v :: (t:ber-length-indicator))] v)) 1234) + (check-equal? (bit-string-case (bytes 131 188 97 78) ([(v :: (t:ber-length-indicator))] v)) + 12345678) -(check-equal? (asn1-ber-encode (asn1-ber-decode-all dsa-key)) dsa-key) -(check-equal? (asn1-ber-encode (asn1-ber-decode-all rsa-key)) rsa-key) + (check-equal? (asn1-ber-encode (asn1-ber-decode-all dsa-key)) dsa-key) + (check-equal? (asn1-ber-encode (asn1-ber-decode-all rsa-key)) rsa-key))