marketplace-ssh-2014/ssh-transport.rkt

485 lines
17 KiB
Racket

#lang racket/base
;;
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
;;;
;;; This file is part of marketplace-ssh.
;;;
;;; marketplace-ssh is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; marketplace-ssh is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with marketplace-ssh. If not, see
;;; <http://www.gnu.org/licenses/>.
(require (planet tonyg/bitsyntax))
(require (planet vyzo/crypto:2:3))
(require racket/set)
(require racket/match)
(require rackunit)
(require "aes-ctr.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)
(struct-out outbound-byte-credit)
(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.
;; An InboundPacket is an (inbound-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 inbound-packet (sequence-number payload message transfer-size) #:prefab)
(struct inbound-credit (amount) #:prefab)
(struct outbound-packet (message) #:prefab)
(struct outbound-byte-credit (amount) #:prefab)
(struct new-keys (is-server?
derive-key
c2s-enc s2c-enc
c2s-mac s2c-mac
c2s-zip s2c-zip)
#:prefab)
(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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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 packet-size-limit (default-packet-limit))
(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)))))))
(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 (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 (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))))
(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))
(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))]
[`(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))]
[`(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)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Encrypted Packet Output
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)]))])))))