diff --git a/safe-io.rkt b/safe-io.rkt index 2797c1a..2b50de9 100644 --- a/safe-io.rkt +++ b/safe-io.rkt @@ -2,6 +2,7 @@ (provide read-line-limited) +;; Port Natural -> (or String EofObject) ;; Uses Internet (CRLF) convention. Limit does not cover the CRLF ;; bytes. (define (read-line-limited port limit) diff --git a/ssh-message-types.rkt b/ssh-message-types.rkt index 008d750..91aa609 100644 --- a/ssh-message-types.rkt +++ b/ssh-message-types.rkt @@ -26,6 +26,7 @@ (struct-out ssh-msg-disconnect) (struct-out ssh-msg-unimplemented) (struct-out ssh-msg-newkeys) + (struct-out ssh-msg-debug) (struct-out ssh-msg-ignore)) (define decoder-map (make-hasheqv)) @@ -216,5 +217,10 @@ (define-ssh-message-type ssh-msg-newkeys SSH_MSG_NEWKEYS) +(define-ssh-message-type ssh-msg-debug SSH_MSG_DEBUG + (boolean always-display?) + (string message) + (string language-tag)) + (define-ssh-message-type ssh-msg-ignore SSH_MSG_IGNORE (string data)) diff --git a/ssh-transport.rkt b/ssh-transport.rkt index 11bd8aa..e4bd395 100644 --- a/ssh-transport.rkt +++ b/ssh-transport.rkt @@ -13,6 +13,10 @@ (require "ssh-message-types.rkt") (require "oakley-groups.rkt") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Data definitions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; 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 @@ -38,16 +42,47 @@ (struct rekey-local (local-algorithms) #:transparent) (struct rekey-in-progress (state) #:transparent) +;; A DecodedPacket is one of the packet structures defined in +;; ssh-message-types.rkt. + +;; A PacketDispatcher is a Hashtable mapping Byte to PacketHandler. + +;; A PacketHandler is a (Bytes DecodedPacket ConnectionState -> ConnectionState). +;; TODO: fix this definition +;; The raw received bytes of the packet are given because sometimes +;; cryptographic operations on the received bytes are mandated by the +;; protocol. + +;; A StreamState is a (stream-state Port Encryptor SupportedCipher +;; Uint32 Natural MacFunction SupportedHmac Natural) representing the +;; negotiated and computed state of the packet-delimiting, +;; -encrypting, and -MACing layer. There's one for each direction +;; (inbound and outbound) of a connection. (struct stream-state (port cipher cipher-description - sequence-number + sequence-number ;; TODO: clip to Uint32 bytes-transferred hmac hmac-description packet-size-limit) #:transparent) +;; A ConnectionState is a (connection StreamState StreamState +;; PacketDispatcher ... TODO fix this) representing the complete state +;; of the SSH transport, authentication, and connection layers. +(struct connection (in + out + dispatch-table + global-request-dispatch-table + channel-open-handler + rekey-state + is-server? + local-id + remote-id + session-id) ;; starts off #f until initial keying + #:transparent) + ;; Generic inputs into the exchange-hash part of key ;; exchange. Diffie-Hellman uses these fields along with the host key, ;; the exchange values, and the shared secret to get the final hash. @@ -65,6 +100,10 @@ (struct supported-hmac (name factory digest-length key-length) #:transparent) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parameters +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define identification-recogniser #rx"^SSH-") (define (identification-line? str) (regexp-match identification-recogniser str)) @@ -74,72 +113,39 @@ (define client-preamble-lines (make-parameter '())) (define client-identification-string (make-parameter "SSH-2.0-RacketSSH_0.0")) -(define (send-preamble-and-identification! out) - (let ((my-id (client-identification-string))) - (for-each (lambda (line) - (when (identification-line? line) - (error 'ssh-session - "Client preamble includes forbidden line ~v" - line)) - (display line out) - (display "\r\n" out)) - (client-preamble-lines)) - (display my-id out) - (display "\r\n" out) - (flush-output out) - my-id)) - -(define (read-preamble-and-identification! in) - (let ((line (read-line-limited in 253))) ;; 255 incl CRLF - (when (eof-object? line) - (error 'ssh-session "EOF while reading connection preamble")) - (if (identification-line? line) - line - (read-preamble-and-identification! in)))) - -(define (disconnect-with-error reason-code format-string . args) - (apply disconnect-with-error/local-info '() reason-code format-string args)) - -(define (disconnect-with-error/local-info 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 - #f)))) - -(define (check-packet-length! actual-length limit block-size) - (when (> actual-length 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))) - -(define (read-bytes/timeout count in timeout) - (sync/timeout timeout (read-bytes-evt count in))) - -(define (read-bytes/decrypt count in timeout decryptor) - (let ((encrypted (read-bytes/timeout count in timeout))) - (cond - ((false? encrypted) #f) - ((eof-object? encrypted) eof) - (else (decryptor encrypted))))) - (define default-packet-limit (make-parameter 65536)) (define rekey-interval (make-parameter 5)) ;;3600)) (define rekey-volume (make-parameter 1000000000)) (define inter-packet-timeout (make-parameter 1)) ;;300)) (define intra-packet-timeout (make-parameter 1)) ;;300)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 @@ -215,44 +221,117 @@ #f 0))))) -(define (bump-sequence-number! state byte-count) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Error signalling +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (disconnect-with-error reason-code format-string . args) + (apply disconnect-with-error/local-info '() reason-code format-string args)) + +(define (disconnect-with-error/local-info 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 + #f)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; I/O Utilities for timeouts and decryption +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (read-bytes/timeout count in timeout) + (sync/timeout timeout (read-bytes-evt count in))) + +(define (read-bytes/decrypt count in timeout decryptor) + (let ((encrypted (read-bytes/timeout count in timeout))) + (cond + ((false? encrypted) #f) + ((eof-object? encrypted) eof) + (else (decryptor encrypted))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Encrypted Packet I/O +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (check-packet-length! actual-length limit block-size) + (when (> actual-length 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))) + +;; TODO: The OpenSSH sshd won't accept a rekeying until authentication +;; is complete, so until we implement the auth layer, we'll get an +;; SSH_MSG_UNIMPLEMENTED when we send SSH_MSG_KEXINIT after the +;; initial keying. + +;; TODO: Remove the incredibly short timeouts above (both inter- and +;; intra-packet-timeout, and rekey-interval). + +;; StreamState Natural -> StreamState +(define (bump-sequence-number state byte-count) (struct-copy stream-state state [sequence-number - (+ 1 (stream-state-sequence-number state))] + ;; It's an unsigned, 32-bit packet counter, so clip it at 32 bits. + (bitwise-and #xffffffff (+ 1 (stream-state-sequence-number state)))] [bytes-transferred (+ byte-count (stream-state-bytes-transferred state))])) +;; ConnectionState Boolean -> +;; (values EndOfFile EndOfFile ConnectionState) +;; or (values #f #f ConnectionState) +;; or (values Bytes DecodedPacket ConnectionState) +;; ;; Read and decode a transport message from in-state. If it can't be ;; decoded (we don't support that message type), complain with a ;; SSH_MSG_UNIMPLEMENTED packet. Finally, return a quadruple of the ;; packet, the decoded message, the updated input state, and the -;; updated output state. May return eof or #f for end-of-file or -;; timeout, respectively, depending on error-on-eof-or-timeout. -(define (read-message in-state out-state [error-on-eof-or-timeout #t]) - (let-values (((packet in-state) (read-packet in-state error-on-eof-or-timeout))) +;; updated output state. May return eof or #f instead of a packet for +;; end-of-file or timeout, respectively, depending on +;; error-on-eof-or-timeout. +(define (read-message conn [error-on-eof-or-timeout #t]) + (let-values (((packet conn) (read-packet conn error-on-eof-or-timeout))) (if (not (bytes? packet)) - (values packet packet in-state out-state) + (values packet packet conn) (let ((message (ssh-message-decode packet))) (write `(received ,message)) (newline) (flush-output) (if message - (values packet message in-state out-state) - (let ((bad-seq-num (- (stream-state-sequence-number in-state) 1))) + (values packet message conn) + (let ((bad-seq-num (most-recent-received-sequence-number conn))) ;; TODO: remove this debug output (display "BAD PACKET ") (display (hex packet)) (newline) (flush-output) - (read-message in-state - (write-message! (ssh-msg-unimplemented bad-seq-num) - out-state) + (read-message (write-message! (ssh-msg-unimplemented bad-seq-num) conn) error-on-eof-or-timeout))))))) +;; ConnectionState -> Natural +;; Returns the sequence number of the most recently received packet. +(define (most-recent-received-sequence-number conn) + (- (stream-state-sequence-number (connection-in conn)) 1)) + +;; Packet format on the wire: ;; uint32 packet_length ;; byte padding_length ;; byte[n1] payload; n1 = packet_length - padding_length - 1 ;; byte[n2] random padding; n2 = padding_length ;; byte[m] mac (Message Authentication Code - MAC); m = mac_length -(define (read-packet in-state error-on-eof-or-timeout) + +;; ConnectionState Boolean -> (values Bytes ConnectionState) +;; Read, MAC-check, and decrypt a single packet from in-state. +(define (read-packet conn error-on-eof-or-timeout) + (define in-state (connection-in conn)) (define cipher (stream-state-cipher in-state)) (define block-size (supported-cipher-block-size (stream-state-cipher-description in-state))) (define in (stream-state-port in-state)) @@ -266,11 +345,11 @@ (if error-on-eof-or-timeout (disconnect-with-error SSH_DISCONNECT_CONNECTION_LOST "Timeout waiting for a packet") - (values #f in-state))) + (values #f conn))) ((eof-object? first-block) (if error-on-eof-or-timeout (error 'read-packet "End-of-file at the start of a packet") - (values first-block in-state))) + (values first-block conn))) (else (let* ((packet-length (integer-bytes->integer first-block #f #t 0 4))) (check-packet-length! packet-length @@ -284,10 +363,11 @@ (let ((bytes-read (+ (check-hmac! (apply-hmac (stream-state-hmac in-state) (stream-state-sequence-number in-state) packet) - in) + in) packet-length))) (values (subbytes packet 5 (+ 5 payload-length)) - (bump-sequence-number! in-state bytes-read)))) + (struct-copy connection conn + [in (bump-sequence-number in-state bytes-read)])))) (if (positive? remaining-to-read) (let ((trailing-blocks (read-bytes/decrypt remaining-to-read in (intra-packet-timeout) decryptor))) @@ -298,11 +378,13 @@ ((eof-object? trailing-blocks) (if error-on-eof-or-timeout (error 'read-packet "End-of-file during a packet") - (values trailing-blocks in-state))) + (values trailing-blocks conn))) (else (read-packet-trailer (bytes-append first-block trailing-blocks))))) (read-packet-trailer first-block))))))) +;; Integer PositiveInteger -> Integer +;; Rounds "what" up to the nearest multiple of "to". (define (round-up what to) (* to (quotient (+ what (- to 1)) to))) @@ -312,11 +394,18 @@ (check-equal? (round-up 8 8) 8) (check-equal? (round-up 9 8) 16) -(define (write-message! message out-state [flush #f]) - (write `(sending ,message)) (newline) (flush-output) - (write-packet! (ssh-message-encode message) out-state flush)) +;; DecodedPacket ConnectionState Optional -> ConnectionState +;; Encodes and writes a DecodedPacket to the ConnectionState. +(define (write-message! message conn [flush #f]) + (write `(sending ,message at out seq num ,(stream-state-sequence-number (connection-out conn)))) + (newline) + (flush-output) + (write-packet! (ssh-message-encode message) conn flush)) -(define (write-packet! payload out-state flush) +;; Bytes ConnectionState Boolean -> ConnectionState +;; Encrypts, MACs and writes a blob to the StreamState. +(define (write-packet! payload conn flush) + (define out-state (connection-out conn)) (define cipher (stream-state-cipher out-state)) (define pad-block-size (supported-cipher-block-size (stream-state-cipher-description out-state))) (define out (stream-state-port out-state)) @@ -324,7 +413,7 @@ ;; 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 padding indicator + 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)) @@ -345,11 +434,18 @@ (write-bytes computed-hmac-bytes out)) (when flush (flush-output out)) - (bump-sequence-number! out-state (+ (bytes-length encrypted-packet) mac-byte-count))) + (struct-copy connection conn + [out (bump-sequence-number out-state + (+ (bytes-length encrypted-packet) mac-byte-count))])) +;; 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)))) +;; Bytes StreamState -> Natural +;; Reads and checks an HMAC for a received packet against its argument. +;; TODO:: Should the read HMAC bytes count against bytes-transferred? (define (check-hmac! computed-hmac-bytes in) (define mac-byte-count (bytes-length computed-hmac-bytes)) (when (positive? mac-byte-count) @@ -370,187 +466,95 @@ "Corrupt MAC")))))) mac-byte-count) -(define null-cipher-description - (supported-cipher 'none - (lambda (enc? key iv) - (error 'null-cipher-description - "Cannot construct null cipher instance")) - 0 - 8 ;; pseudo-block-size for packet I/O - 0)) - -(define (null-hmac blob) - #"") - -(define null-hmac-description - (supported-hmac 'none - (lambda (key) - (error 'null-hmac-description - "Cannot construct null hmac instance")) - 0 - 0)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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)) -(define (key-exchange-init? encoded-packet) - (= (encoded-packet-msg-type encoded-packet) SSH_MSG_KEXINIT)) +;; 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)))))) -(define (acceptable-during-key-exchange? encoded-packet) - ;; See end of RFC 4253 section 7.1. - (let ((msg-type (encoded-packet-msg-type encoded-packet))) - (and (ssh-msg-type-transport-layer? msg-type) - (not (memv msg-type (list SSH_MSG_SERVICE_REQUEST - SSH_MSG_SERVICE_ACCEPT - SSH_MSG_KEXINIT)))))) +;; 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)])) -(define (default-stream-state port) - (stream-state port - #f ;; cipher - null-cipher-description - 0 - 0 - null-hmac - null-hmac-description - (default-packet-limit))) +;; ConnectionState 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 (ssh-session role in out seed message-handler) - (define local-identification-string (send-preamble-and-identification! out)) - (with-handlers - ((exn:fail? (lambda (e) - (close-input-port in) - (close-output-port out) - (raise e)))) - (let ((peer-identification-string (read-preamble-and-identification! in))) - ;; Each identification string is both a cleartext indicator that - ;; we've reached some notion of the right place and also input to - ;; the hash function used during D-H key exchange. - (when (not (regexp-match (required-peer-identification-regex) - peer-identification-string)) - (display "Invalid identification\r\n" out) - (flush-output out) - (error 'ssh-session - "Invalid peer identification string ~v" - peer-identification-string)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Handlers for core transport packet types +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define result - (let ((orig-in-state (default-stream-state in)) - (orig-out-state (default-stream-state out))) - (ssh-session-loop role - local-identification-string - peer-identification-string - message-handler - #f - seed - (rekey-in-seconds-or-bytes -1 -1 orig-in-state orig-out-state) - orig-in-state - orig-out-state))) +;; PacketHandler for handling SSH_MSG_DISCONNECT. +(define (handle-msg-disconnect packet message conn) + (raise (exn:fail:contract:protocol + (format "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)))) + (current-continuation-marks) + (ssh-msg-disconnect-reason-code message) + '() + #t))) - (close-input-port in) - (close-output-port out) - result))) +;; PacketHandler for handling SSH_MSG_IGNORE. +(define (handle-msg-ignore packet message conn) + ;; TODO: suppress debug printing. + (write message) + (newline) + conn) -(define (rekey-in-seconds-or-bytes delta-seconds delta-bytes in-state out-state) - (rekey-wait (+ (current-seconds) delta-seconds) - (+ (stream-state-bytes-transferred in-state) - (stream-state-bytes-transferred out-state) - delta-bytes))) +;; 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.")) -(define (time-to-rekey? rekey in-state out-state) - (and (rekey-wait? rekey) - (or (>= (current-seconds) (rekey-wait-deadline rekey)) - (>= (+ (stream-state-bytes-transferred in-state) - (stream-state-bytes-transferred out-state)) - (rekey-wait-threshold-bytes rekey))))) - -(define (maybe-send-disconnect-message! e out-state) - (if (exn:fail:contract:protocol-originated-at-peer? e) - out-state - (write-message! (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code e) - (string->bytes/utf-8 (exn-message e)) - #"") - out-state - #t))) - -(define (write-messages! outbound-messages out-state) - (let ((final-state (foldl write-message! out-state outbound-messages))) - (flush-output (stream-state-port final-state)) - final-state)) - -(define (ssh-session-loop role local-id remote-id message-handler - session-id - seed rekey in-state out-state) - (let loop ((seed seed) - (rekey rekey) - (in-state in-state) - (out-state out-state)) - (with-handlers - ((exn:fail:contract:protocol? (lambda (e) - (maybe-send-disconnect-message! e out-state) - (raise e)))) - (if (time-to-rekey? rekey in-state out-state) - (let ((algs ((local-algorithm-list)))) - (loop seed - (rekey-local algs) - in-state - (write-message! algs out-state #t))) - (let-values (((packet message in-state out-state) - (read-message in-state out-state #f))) - (cond - ((eof-object? packet) seed) - ((false? packet) - ;; Timeout waiting for a message. - (loop seed rekey in-state out-state)) - ((key-exchange-init? packet) - (if (rekey-in-progress? rekey) - (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR - "Received SSH_MSG_KEXINIT during ongoing key exchange") - (let* ((algs (if (rekey-local? rekey) - (rekey-local-local-algorithms rekey) - ((local-algorithm-list)))) - (encoded-algs (ssh-message-encode algs)) - (out-state (if (rekey-wait? rekey) - (write-packet! encoded-algs out-state #t) - out-state))) - (start-key-exchange session-id ;; may be #f, in which case will change below - role - local-id - encoded-algs - algs - remote-id - packet - message - in-state - out-state - (lambda (session-id in-state out-state) - (ssh-session-loop - role - local-id - remote-id - message-handler - session-id ;; just in case it changed - seed - (rekey-in-seconds-or-bytes (rekey-interval) - (rekey-volume) - in-state - out-state) - in-state - (write-message! (ssh-msg-ignore #"hello world") - out-state #t))))))) - ((and (rekey-in-progress? rekey) - (not (acceptable-during-key-exchange? packet))) - (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR - "Unacceptable packet type ~v" - (encoded-packet-msg-type packet))) - (else - (message-handler seed - message - (lambda (outbound-messages new-seed) - (loop new-seed - rekey - in-state - (write-messages! outbound-messages out-state))))))))))) +;; PacketHandler for handling SSH_MSG_DEBUG. +(define (handle-msg-debug packet message conn) + ;; TODO: use Racket log API. + (write message) + (newline) + conn) +;; (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 client-list0 (getter client-algs)) (define server-list (getter server-algs)) @@ -565,15 +569,75 @@ ((memq (car client-list) server-list) (car client-list)) (else (loop (cdr client-list)))))) -(define (apply-negotiated-options state role outbound derive-key +(define (check-host-key! host-key) + ;; TODO: If we are *re*keying, worth checking here that the key hasn't *changed* either. + (write `(TODO check-host-key! ,(hex (bit-string->bytes host-key)))) (newline) (flush-output) + (void)) + +;; ExchangeHashInfo Bytes Natural Natural Natural -> Bytes +;; Computes the session ID as defined by SSH's DH key exchange method. +(define (dh-exchange-hash hash-info host-key e f k) + (let ((block-to-hash + (bit-string->bytes + (bit-string ((string->bytes/utf-8 (exchange-hash-info-client-id hash-info)) :: (t:string)) + ((string->bytes/utf-8 (exchange-hash-info-server-id hash-info)) :: (t:string)) + ((exchange-hash-info-client-kexinit-bytes hash-info) :: (t:string)) + ((exchange-hash-info-server-kexinit-bytes hash-info) :: (t:string)) + (host-key :: (t:string)) + (e :: (t:mpint)) + (f :: (t:mpint)) + (k :: (t:mpint)))))) + ;;(pretty-print `((block-to-hash ,(hex block-to-hash)))) + (sha1 block-to-hash))) + +;; ExchangeHashInfo Symbol Symbol ConnectionState +;; (Bytes Bytes Symbol ConnectionState -> ConnectionState) +;; -> ConnectionState +;; 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 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)) + (oneshot-handler (write-message! (ssh-msg-kexdh-init (bit-string->integer public-key #t #f)) + conn #t) + 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 exchange-hash + (dh-exchange-hash hash-info + (ssh-msg-kexdh-reply-host-key message) + (bit-string->integer public-key #t #f) + f + (bit-string->integer shared-secret #t #f))) + ;; (pretty-print `((public-key ,(hex public-key)) + ;; (f-as-bytes ,(hex f-as-bytes)) + ;; (shared-secret ,(hex shared-secret)) + ;; (exchange-hash ,(hex exchange-hash)))) + (check-host-key! (ssh-msg-kexdh-reply-host-key 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)))) + +;; StreamState Boolean Boolean (Bytes Maybe -> Bytes) +;; Symbol Symbol Symbol Symbol Symbol Symbol +;; -> StreamState +;; Figures out which encryption, compression, and MAC option to use +;; for this stream, and initializes the relevant state vectors and +;; behaviours. +(define (apply-negotiated-options state is-server? is-outbound? derive-key c2s-enc s2c-enc c2s-mac s2c-mac c2s-zip s2c-zip) ;; TODO: zip ;; TODO: make this less ugly. Compute all the keys, select just the ones we need afterward? - (define c2s (case role - ((client) outbound) - ((server) (not outbound)))) + (define c2s (if is-server? (not is-outbound?) is-outbound?)) ;; c2s true iff stream is serverward (define enc (if c2s c2s-enc s2c-enc)) (define mac (if c2s c2s-mac s2c-mac)) (define zip (if c2s c2s-zip s2c-zip)) @@ -587,8 +651,9 @@ (define iv (derive-key (if c2s #"A" #"B") (supported-cipher-iv-length c))) (define factory (supported-cipher-factory c)) - ;;(pretty-print `(,role ,(if c2s 'c2s 's2c) (key ,(hex key)) (iv ,(hex iv)))) - (factory outbound key iv))) + ;; (pretty-print `(,is-server? ,(if c2s 'c2s 's2c) ,enc + ;; (key ,(hex key)) (iv ,(hex iv)))) + (factory is-outbound? key iv))) (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Could not find driver for encryption algorithm ~v" enc)))] @@ -599,28 +664,36 @@ (define factory (supported-hmac-factory h)) (define key (derive-key (if c2s #"E" #"F") (supported-hmac-key-length h))) - ;;(pretty-print `(,role ,(if c2s 'c2s 's2c) (key ,(hex key)))) + ;; (pretty-print `(,is-server? ,(if c2s 'c2s 's2c) ,mac + ;; (key ,(hex key)))) (factory key))) (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Could not find driver for HMAC algorithm ~v" mac)))])) -(define (start-key-exchange old-session-id ;; bytes or #f - role ;; 'client or 'server - local-id ;; string - encoded-local-algs ;; bytes, an encoded ssh-msg-kexinit - local-algs ;; ssh-msg-kexinit - remote-id ;; string - encoded-remote-algs ;; bytes, an encoded ssh-msg-kexinit - remote-algs ;; ssh-msg-kexinit - in-state - out-state - finish-key-exchange) - (when (not (memq role '(client server))) - (error 'start-key-exchange "Illegal role ~v, must be either 'client or 'server" role)) +(define (QQ conn) + (write `(QQ ,(stream-state-sequence-number (connection-out conn)))) (newline) + (write-message! (ssh-msg-debug #t #"Debug trace" #"") conn #t)) - (define c (case role ((client) local-algs) ((server) remote-algs))) - (define s (case role ((client) remote-algs) ((server) local-algs))) +;; 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 encoded-local-algs (ssh-message-encode local-algs)) + (define remote-algs message) + (define encoded-remote-algs packet) + + (when (rekey-wait? rekey) + (set! conn (write-packet! encoded-local-algs conn #t))) + + (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)) @@ -655,111 +728,221 @@ (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 in-state out-state) - (case role - ((client) (perform-client-key-exchange (exchange-hash-info local-id - remote-id - encoded-local-algs - encoded-remote-algs) - kex-alg host-key-alg in-state out-state - continue-after-key-exchange)) - ((server) (error 'start-key-exchange "Server role unimplemented")))) + (define (continue-after-discard conn) + (if is-server? + (error 'start-key-exchange "Server role unimplemented") + (perform-client-key-exchange (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))) - (define (continue-after-key-exchange shared-secret exchange-hash hash-alg in-state out-state) - (let ((session-id (if old-session-id - old-session-id ;; don't overwrite existing ID - exchange-hash)) - (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 - ((false? 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)))))))))) - (let-values (((newkeys-packet newkeys-message in-state out-state) - (read-message in-state out-state))) - (when (not (ssh-msg-newkeys? newkeys-message)) - (disconnect-with-error/local-info `((message ,newkeys-message)) - SSH_DISCONNECT_PROTOCOL_ERROR - "Expected SSH_MSG_NEWKEYS")) - (let ((out-state (write-message! (ssh-msg-newkeys) out-state))) - (finish-key-exchange session-id - (apply-negotiated-options in-state role #f derive-key - c2s-enc s2c-enc - c2s-mac s2c-mac - c2s-zip s2c-zip) - (apply-negotiated-options out-state role #t derive-key - c2s-enc s2c-enc - c2s-mac s2c-mac - c2s-zip s2c-zip)))))) + (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 + ((false? 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)))))))))) + (oneshot-handler (struct-copy connection conn + [session-id session-id]) ;; just in case it changed + SSH_MSG_NEWKEYS + (lambda (newkeys-packet newkeys-message pre-newkeys-conn) + ;; First, send our SSH_MSG_NEWKEYS, + ;; incrementing the various counters, and then + ;; apply the new algorithms. + (define conn (write-message! (ssh-msg-newkeys) pre-newkeys-conn #t)) + (struct-copy connection conn + [in + (apply-negotiated-options (connection-in conn) + (connection-is-server? conn) + #f + derive-key + c2s-enc s2c-enc + c2s-mac s2c-mac + c2s-zip s2c-zip)] + [out + (apply-negotiated-options (connection-out conn) + (connection-is-server? conn) + #t + derive-key + c2s-enc s2c-enc + c2s-mac s2c-mac + c2s-zip s2c-zip)] + [rekey-state + (rekey-in-seconds-or-bytes (rekey-interval) + (rekey-volume) + (connection-in conn) + (connection-out conn))])))) (if should-discard-first-kex-packet - (let-values (((discarded-packet discarded-message in-state out-state) - (read-message in-state out-state))) - (continue-after-discard in-state out-state)) - (continue-after-discard in-state out-state))) + (let-values (((discarded-packet discarded-message conn) (read-message conn))) + (continue-after-discard conn)) + (continue-after-discard conn))) -(define (check-host-key! host-key) - ;; TODO: If we are *re*keying, worth checking here that the key hasn't *changed* either. - (write `(TODO check-host-key! ,(hex (bit-string->bytes host-key)))) (newline) (flush-output) - (void)) +;; 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 (perform-client-key-exchange hash-info kex-alg host-key-alg in-state out-state finish) - (case kex-alg - ((diffie-hellman-group14-sha1 diffie-hellman-group1-sha1) - (let ((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 - (let*-values (((private-key public-key) (generate-key group)) - ((out-state) - (write-message! (ssh-msg-kexdh-init (bit-string->integer public-key #t #f)) - out-state - #t)) - ((packet message in-state out-state) - (read-message in-state out-state))) - (if (not (ssh-msg-kexdh-reply? message)) - (disconnect-with-error/local-info `((message ,message)) - SSH_DISCONNECT_KEY_EXCHANGE_FAILED - "Unexpected packet type") - (let* ((f (ssh-msg-kexdh-reply-f message)) - (f-width (mpint-width f)) - (f-as-bytes (integer->bit-string f (* 8 f-width) #t)) - (shared-secret (compute-key private-key f-as-bytes)) - (hash-alg sha1) - (exchange-hash (dh-exchange-hash hash-info - (ssh-msg-kexdh-reply-host-key message) - (bit-string->integer public-key #t #f) - f - (bit-string->integer shared-secret #t #f)))) - ;; (pretty-print `((public-key ,(hex public-key)) - ;; (f-as-bytes ,(hex f-as-bytes)) - ;; (shared-secret ,(hex shared-secret)) - ;; (exchange-hash ,(hex exchange-hash)))) - (check-host-key! (ssh-msg-kexdh-reply-host-key message)) - (finish shared-secret exchange-hash hash-alg in-state out-state)))))) - (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED - "Bad key-exchange algorithm ~v" kex-alg)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Session choreography +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (dh-exchange-hash hash-info host-key e f k) - (let ((block-to-hash - (bit-string->bytes - (bit-string ((string->bytes/utf-8 (exchange-hash-info-client-id hash-info)) :: (t:string)) - ((string->bytes/utf-8 (exchange-hash-info-server-id hash-info)) :: (t:string)) - ((exchange-hash-info-client-kexinit-bytes hash-info) :: (t:string)) - ((exchange-hash-info-server-kexinit-bytes hash-info) :: (t:string)) - (host-key :: (t:string)) - (e :: (t:mpint)) - (f :: (t:mpint)) - (k :: (t:mpint)))))) - ;;(pretty-print `((block-to-hash ,(hex block-to-hash)))) - (sha1 block-to-hash))) +(define (default-stream-state port) + (stream-state port + #f ;; cipher + null-cipher-description + 0 + 0 + null-hmac + null-hmac-description + (default-packet-limit))) + +(define (send-preamble-and-identification! out) + (let ((my-id (client-identification-string))) + (for-each (lambda (line) + (when (identification-line? line) + (error 'ssh-session + "Client preamble includes forbidden line ~v" + line)) + (display line out) + (display "\r\n" out)) + (client-preamble-lines)) + (display my-id out) + (display "\r\n" out) + (flush-output out) + my-id)) + +;; Port -> String +(define (read-preamble-and-identification! in) + (let ((line (read-line-limited in 253))) ;; 255 incl CRLF + (when (eof-object? line) + (error 'ssh-session "EOF while reading connection preamble")) + (if (identification-line? line) + line + (read-preamble-and-identification! in)))) + +(define (ssh-session role in out) + (define local-identification-string (send-preamble-and-identification! out)) + (with-handlers + ((exn:fail? (lambda (e) + (close-input-port in) + (close-output-port out) + (raise e)))) + (let ((peer-identification-string (read-preamble-and-identification! in))) + ;; Each identification string is both a cleartext indicator that + ;; we've reached some notion of the right place and also input to + ;; the hash function used during D-H key exchange. + (when (not (regexp-match (required-peer-identification-regex) + peer-identification-string)) + (display "Invalid identification\r\n" out) + (flush-output out) + (error 'ssh-session + "Invalid peer identification string ~v" + peer-identification-string)) + + (define result + (let ((in-state (default-stream-state in)) + (out-state (default-stream-state out))) + (run-ssh-session (connection in-state + out-state + base-packet-dispatcher + (hash) ;; TODO: make customizable + (lambda args + (error 'TODO-channel-open-handler)) + (rekey-in-seconds-or-bytes -1 -1 in-state out-state) + (case role + ((client) #f) + ((server) #t)) + local-identification-string + peer-identification-string + #f)))) + (close-input-port in) + (close-output-port out) + result))) + +(define (rekey-in-seconds-or-bytes delta-seconds delta-bytes in-state out-state) + (rekey-wait (+ (current-seconds) delta-seconds) + (+ (stream-state-bytes-transferred in-state) + (stream-state-bytes-transferred out-state) + delta-bytes))) + +(define (time-to-rekey? rekey conn) + (and (rekey-wait? rekey) + (or (>= (current-seconds) (rekey-wait-deadline rekey)) + (>= (+ (stream-state-bytes-transferred (connection-in conn)) + (stream-state-bytes-transferred (connection-out conn))) + (rekey-wait-threshold-bytes rekey))))) + +(define (maybe-send-disconnect-message! e conn) + (if (exn:fail:contract:protocol-originated-at-peer? e) + conn + (write-message! (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code e) + (string->bytes/utf-8 (exn-message e)) + #"") + conn + #t))) + +(define (write-messages! outbound-messages conn) + (let ((final-state (foldl write-message! conn outbound-messages))) + (flush-output (stream-state-port (connection-out final-state))) + final-state)) + +;; ConnectionState -> TODO:? +(define (run-ssh-session conn) + (with-handlers + ((exn:fail:contract:protocol? (lambda (e) + (maybe-send-disconnect-message! e conn) + (raise e)))) + (let loop ((new-connection-state conn)) + ;; YUCK: in order to be able to send our disconnect messages in + ;; the with-handlers above, we need to know the most up-to-date + ;; connection state. This is a thorny, ugly problem. + (set! conn new-connection-state) + (if (time-to-rekey? (connection-rekey-state conn) conn) + (let ((algs ((local-algorithm-list)))) + (loop (struct-copy connection (write-message! algs conn #t) + [rekey-state (rekey-local algs)]))) + (let-values (((packet message conn) (read-message conn #f))) + (cond + ((eof-object? packet) + (error 'TODO-disconnected-without-shutdown)) + ((false? packet) + ;; Timeout waiting for a message. + (loop conn)) + (else + (let* ((packet-type-number (encoded-packet-msg-type packet)) + (packet-handler (hash-ref (connection-dispatch-table conn) + packet-type-number + #f))) + (if packet-handler + (loop (packet-handler packet message conn)) + (loop (ssh-msg-unimplemented + (most-recent-received-sequence-number conn)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Test driver code +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require racket/tcp) (require racket/pretty) @@ -768,9 +951,5 @@ 2323 ;;22 ))) - (ssh-session 'client - i o #f - (lambda (seed message continue-reading) - (pretty-print message) - (continue-reading (list) seed))))) + (ssh-session 'client i o))) (t)