Updates matching latest syndicate/rkt changes

This commit is contained in:
Tony Garnock-Jones 2021-06-17 15:57:55 +02:00
parent 00f5e2b55e
commit 995a81c7e6
9 changed files with 225 additions and 218 deletions

View File

@ -9,10 +9,13 @@
"base"
"bitsyntax"
"crypto"
"crypto-lib"
"preserves"
"syndicate"
"unix-socket-lib"
"sandbox-lib"
))
(define build-deps '("rackunit-lib"))

View File

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

View File

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

View File

@ -0,0 +1,3 @@
version 1 .
embeddedType EntityRef.Ref .

View File

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

View File

@ -2,17 +2,6 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(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)

View File

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

View File

@ -2,15 +2,6 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(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)))))

View File

@ -2,43 +2,44 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(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))