400 lines
14 KiB
Racket
400 lines
14 KiB
Racket
#lang racket/base
|
|
|
|
(require (planet tonyg/bitsyntax))
|
|
(require (planet vyzo/crypto:2:3))
|
|
(require racket/port)
|
|
(require racket/class)
|
|
(require racket/match)
|
|
|
|
(require rackunit)
|
|
|
|
(require "aes-ctr.rkt")
|
|
(require "conversation.rkt")
|
|
|
|
(require "ssh-numbers.rkt")
|
|
(require "ssh-message-types.rkt")
|
|
(require "ssh-exceptions.rkt")
|
|
|
|
(provide (struct-out received-packet)
|
|
(struct-out new-keys)
|
|
|
|
default-packet-limit
|
|
local-algorithm-list
|
|
|
|
ssh-reader
|
|
ssh-writer)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Data definitions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; A DecodedPacket is one of the packet structures defined in
|
|
;; ssh-message-types.rkt.
|
|
|
|
;; A ReceivedPacket is a (received-packet Number Bytes Maybe<DecodedPacket> Number)
|
|
;; representing a packet read from the socket, its sequence number,
|
|
;; and the total number of bytes involved in its reception.
|
|
(struct received-packet (sequence-number payload message transfer-size) #:transparent)
|
|
|
|
(struct new-keys (is-server?
|
|
derive-key
|
|
c2s-enc s2c-enc
|
|
c2s-mac s2c-mac
|
|
c2s-zip s2c-zip)
|
|
#:transparent)
|
|
|
|
(struct crypto-configuration (cipher
|
|
cipher-description
|
|
hmac
|
|
hmac-description)
|
|
#:transparent)
|
|
|
|
;; Description of a supported cipher.
|
|
(struct supported-cipher (name factory key-length block-size iv-length)
|
|
#:transparent)
|
|
|
|
;; Description of a supported hmac algorithm.
|
|
(struct supported-hmac (name factory digest-length key-length)
|
|
#:transparent)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Parameters
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define default-packet-limit (make-parameter 65536))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Encryption, MAC, and Compression algorithm descriptions and parameters
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; "none" cipher description.
|
|
(define null-cipher-description
|
|
(supported-cipher 'none
|
|
(lambda (enc? key iv)
|
|
(lambda (block)
|
|
block))
|
|
0
|
|
8 ;; pseudo-block-size for packet I/O
|
|
0))
|
|
|
|
;; "none" HMAC function.
|
|
(define (null-hmac blob)
|
|
#"")
|
|
|
|
;; "none" HMAC description.
|
|
(define null-hmac-description
|
|
(supported-hmac 'none
|
|
(lambda (key)
|
|
(error 'null-hmac-description
|
|
"Cannot construct null hmac instance"))
|
|
0
|
|
0))
|
|
|
|
(define (make-evp-cipher-entry name cipher)
|
|
(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)))
|
|
|
|
(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)
|
|
)) ;; TODO: actually test these!
|
|
|
|
(define (make-hmac-entry name digest key-length-or-false)
|
|
(let* ((digest-length (digest-size digest))
|
|
(key-length (or key-length-or-false digest-length)))
|
|
(list name
|
|
(supported-hmac name
|
|
(lambda (key)
|
|
(lambda (blob)
|
|
(hmac digest 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)))
|
|
|
|
(define supported-compression-algorithms '(none)) ;; TODO: zlib, and zlib delayed
|
|
|
|
(define local-algorithm-list
|
|
(let ((crypto-names (map car supported-crypto-algorithms))
|
|
(mac-names (map car supported-hmac-algorithms)))
|
|
(make-parameter
|
|
(lambda ()
|
|
(ssh-msg-kexinit (random-bytes 16)
|
|
'(diffie-hellman-group14-sha1
|
|
diffie-hellman-group1-sha1)
|
|
'(ssh-dss) ;; TODO: offer ssh-rsa. This will
|
|
;; involve replicating the tedious
|
|
;; crypto operations from the spec
|
|
;; rather than being able to use
|
|
;; the builtins from OpenSSL.
|
|
crypto-names
|
|
crypto-names
|
|
mac-names
|
|
mac-names
|
|
supported-compression-algorithms
|
|
supported-compression-algorithms
|
|
'()
|
|
'()
|
|
#f
|
|
0)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Cryptographic stream configuration
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define initial-crypto-configuration
|
|
(crypto-configuration #f
|
|
null-cipher-description
|
|
null-hmac
|
|
null-hmac-description))
|
|
|
|
(define (apply-negotiated-options nk is-outbound?)
|
|
(match-define (new-keys is-server?
|
|
derive-key
|
|
c2s-enc s2c-enc
|
|
c2s-mac s2c-mac
|
|
c2s-zip s2c-zip) nk)
|
|
;; TODO: zip
|
|
;; TODO: make this less ugly. Compute all the keys, select just the ones we need afterward?
|
|
(define c2s
|
|
;; c2s true iff stream is serverward
|
|
(if is-server? (not is-outbound?) is-outbound?))
|
|
(define enc (if c2s c2s-enc s2c-enc))
|
|
(define mac (if c2s c2s-mac s2c-mac))
|
|
(define zip (if c2s c2s-zip s2c-zip))
|
|
|
|
(define cipher-description
|
|
(cond
|
|
((assq enc supported-crypto-algorithms) => cadr)
|
|
(else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
|
"Could not find driver for encryption algorithm ~v"
|
|
enc))))
|
|
(define cipher
|
|
((supported-cipher-factory cipher-description)
|
|
is-outbound?
|
|
(derive-key (if c2s #"C" #"D") (supported-cipher-key-length cipher-description))
|
|
(derive-key (if c2s #"A" #"B") (supported-cipher-iv-length cipher-description))))
|
|
|
|
(define hmac-description
|
|
(cond
|
|
((assq mac supported-hmac-algorithms) => cadr)
|
|
(else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
|
"Could not find driver for HMAC algorithm ~v"
|
|
mac))))
|
|
(define hmac
|
|
((supported-hmac-factory hmac-description)
|
|
(derive-key (if c2s #"E" #"F") (supported-hmac-key-length hmac-description))))
|
|
|
|
(crypto-configuration cipher cipher-description
|
|
hmac hmac-description))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Transport utilities
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; MacFunction Natural Bytes -> Bytes
|
|
;; Computes the HMAC trailer for a given blob at the given sequence number.
|
|
(define (apply-hmac mac sequence-number packet)
|
|
(mac (bit-string->bytes (bit-string-append (integer->bit-string sequence-number 32 #t)
|
|
packet))))
|
|
|
|
(define (check-packet-length! actual-length limit block-size)
|
|
(when (> actual-length limit)
|
|
(log-warning (format "Packet of length ~v exceeded our limit of ~v"
|
|
actual-length
|
|
limit)))
|
|
(when (> actual-length (* 2 limit))
|
|
;; TODO: For some reason, OpenSSH seems to occasionally slightly
|
|
;; 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?
|
|
"Packet of length ~v is longer than packet limit ~v"
|
|
actual-length
|
|
limit))
|
|
(when (not (zero? (modulo (+ actual-length 4) block-size)))
|
|
;; the +4 is because the length sent on the wire doesn't include
|
|
;; 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
|
|
"Packet of length ~v is not a multiple of block size ~v"
|
|
actual-length
|
|
block-size)))
|
|
|
|
;; Integer PositiveInteger -> Integer
|
|
;; Rounds "what" up to the nearest multiple of "to".
|
|
(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)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Encrypted Packet Input
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (ssh-reader in room)
|
|
(define handle (join-room room 'read-thread))
|
|
(define packet-size-limit (default-packet-limit))
|
|
|
|
(define (main-loop config sequence-number remaining-credit)
|
|
(match-define (crypto-configuration cipher cipher-description
|
|
hmac hmac-description) config)
|
|
(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 (handle-packet-start first-block)
|
|
(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! computed-hmac-bytes)
|
|
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
|
(when (positive? mac-byte-count)
|
|
(match (read-bytes mac-byte-count in)
|
|
((? eof-object?) (disconnect-with-error SSH_DISCONNECT_CONNECTION_LOST
|
|
"EOF instead of MAC"))
|
|
(received-hmac-bytes
|
|
(when (not (equal? computed-hmac-bytes received-hmac-bytes))
|
|
(disconnect-with-error/local-info `((expected-hmac ,computed-hmac-bytes)
|
|
(actual-hmac ,received-hmac-bytes))
|
|
SSH_DISCONNECT_MAC_ERROR
|
|
"Corrupt MAC")))))
|
|
mac-byte-count)
|
|
|
|
(define (finish-packet packet)
|
|
(define bytes-read
|
|
(+ packet-length (check-hmac! (apply-hmac hmac sequence-number packet))))
|
|
(define payload (subbytes packet 5 (+ 5 payload-length)))
|
|
(send handle say
|
|
(received-packet sequence-number payload (ssh-message-decode payload) bytes-read)
|
|
'packet)
|
|
(main-loop config (+ sequence-number 1) (- remaining-credit 1)))
|
|
|
|
(if (positive? remaining-to-read)
|
|
(match (read-bytes remaining-to-read in)
|
|
((? eof-object?) (disconnect-with-error SSH_DISCONNECT_CONNECTION_LOST
|
|
"EOF mid-way through reading a packet"))
|
|
(encrypted (finish-packet (bytes-append first-block (decryptor encrypted)))))
|
|
(finish-packet first-block)))
|
|
|
|
(let wait-for-event ()
|
|
(sync (if (positive? remaining-credit)
|
|
(handle-evt (read-bytes-evt first-block-size in)
|
|
(lambda (encrypted)
|
|
(cond
|
|
((eof-object? encrypted)
|
|
(send handle depart 'eof)) ;; we gracefully exit
|
|
(else (handle-packet-start (decryptor encrypted))))))
|
|
never-evt)
|
|
(handle-evt (send handle listen-evt)
|
|
(match-lambda
|
|
((arrived _) (wait-for-event))
|
|
((and departure (departed _ _)) (send handle depart departure))
|
|
((says _ (credit 'read-thread amount) _)
|
|
(main-loop config sequence-number (+ remaining-credit amount)))
|
|
((says _ (? new-keys? nk) _)
|
|
(main-loop (apply-negotiated-options nk #f)
|
|
sequence-number remaining-credit))
|
|
((says _ _ _) (wait-for-event)))))))
|
|
|
|
(with-handlers ((exn? (lambda (e)
|
|
(close-input-port in)
|
|
(raise e))))
|
|
(main-loop initial-crypto-configuration 0 0)
|
|
(close-input-port in)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Encrypted Packet Output
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (ssh-writer out room)
|
|
(define handle (join-room room 'write-thread))
|
|
|
|
(define (main-loop config sequence-number)
|
|
(match-define (crypto-configuration cipher cipher-description
|
|
hmac hmac-description) config)
|
|
|
|
(match (send handle listen)
|
|
((arrived _)
|
|
(main-loop config sequence-number))
|
|
((and departure (departed _ _)) (send handle depart departure))
|
|
((says _ (? new-keys? nk) _)
|
|
(main-loop (apply-negotiated-options nk #t) sequence-number))
|
|
((says _ 'flush _)
|
|
(flush-output out)
|
|
(main-loop config sequence-number))
|
|
((says _ (? ssh-msg? message) _)
|
|
(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))
|
|
(write-bytes encrypted-packet out)
|
|
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
|
(when (positive? mac-byte-count)
|
|
(write-bytes computed-hmac-bytes out))
|
|
(send handle say (+ (bytes-length encrypted-packet) mac-byte-count) 'output-byte-count)
|
|
(main-loop config (+ sequence-number 1)))
|
|
((says _ _ _)
|
|
(main-loop config sequence-number))))
|
|
|
|
(with-handlers ((exn? (lambda (e)
|
|
(close-output-port out)
|
|
(raise e))))
|
|
(main-loop initial-crypto-configuration 0)
|
|
(close-output-port out)))
|