2011-08-11 04:25:28 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
|
|
|
(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 (planet tonyg/bitsyntax))
|
|
|
|
(require racket/bytes)
|
|
|
|
|
|
|
|
(require rackunit)
|
|
|
|
|
|
|
|
(provide ssh-message-decode
|
|
|
|
ssh-message-encode)
|
|
|
|
|
2011-08-16 06:46:45 +00:00
|
|
|
(provide t:boolean
|
|
|
|
t:string
|
|
|
|
t:mpint
|
|
|
|
mpint-width
|
|
|
|
t:name-list)
|
|
|
|
|
2012-05-15 18:22:00 +00:00
|
|
|
(provide (struct-out ssh-msg-kexinit)
|
2011-08-16 06:46:45 +00:00
|
|
|
(struct-out ssh-msg-kexdh-init)
|
|
|
|
(struct-out ssh-msg-kexdh-reply)
|
|
|
|
(struct-out ssh-msg-disconnect)
|
|
|
|
(struct-out ssh-msg-unimplemented)
|
|
|
|
(struct-out ssh-msg-newkeys)
|
2011-10-18 01:13:46 +00:00
|
|
|
(struct-out ssh-msg-debug)
|
2011-10-24 01:26:13 +00:00
|
|
|
(struct-out ssh-msg-ignore)
|
2011-10-24 14:47:12 +00:00
|
|
|
(struct-out ssh-msg-service-request)
|
|
|
|
(struct-out ssh-msg-service-accept)
|
|
|
|
(struct-out ssh-msg-userauth-request)
|
|
|
|
(struct-out ssh-msg-userauth-failure)
|
|
|
|
(struct-out ssh-msg-userauth-success)
|
|
|
|
(struct-out ssh-msg-global-request)
|
|
|
|
(struct-out ssh-msg-request-success)
|
|
|
|
(struct-out ssh-msg-request-failure)
|
|
|
|
(struct-out ssh-msg-channel-open)
|
|
|
|
(struct-out ssh-msg-channel-open-confirmation)
|
|
|
|
(struct-out ssh-msg-channel-open-failure)
|
|
|
|
(struct-out ssh-msg-channel-window-adjust)
|
|
|
|
(struct-out ssh-msg-channel-data)
|
|
|
|
(struct-out ssh-msg-channel-extended-data)
|
|
|
|
(struct-out ssh-msg-channel-eof)
|
|
|
|
(struct-out ssh-msg-channel-close)
|
|
|
|
(struct-out ssh-msg-channel-request)
|
|
|
|
(struct-out ssh-msg-channel-success)
|
|
|
|
(struct-out ssh-msg-channel-failure)
|
|
|
|
)
|
2011-08-11 05:11:55 +00:00
|
|
|
|
2012-05-15 18:22:00 +00:00
|
|
|
(define encoder-map (make-hasheqv))
|
2011-08-11 04:25:28 +00:00
|
|
|
(define decoder-map (make-hasheqv))
|
|
|
|
|
|
|
|
(define (ssh-message-decode packet)
|
2011-08-16 06:46:45 +00:00
|
|
|
(define type-code (bytes-ref packet 0))
|
|
|
|
(define decoder (hash-ref decoder-map type-code #f))
|
|
|
|
(if decoder
|
|
|
|
(decoder packet)
|
|
|
|
#f))
|
2011-08-11 04:25:28 +00:00
|
|
|
|
|
|
|
(define (ssh-message-encode m)
|
2012-05-15 18:22:00 +00:00
|
|
|
(bit-string->bytes ((hash-ref encoder-map (prefab-struct-key m)) m)))
|
2011-08-11 04:25:28 +00:00
|
|
|
|
|
|
|
(define-syntax define-ssh-message-type
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ name type-byte-value (field-type field-name) ...)
|
|
|
|
(begin
|
2012-05-15 18:22:00 +00:00
|
|
|
(struct name (field-name ...) #:prefab)
|
|
|
|
(hash-set! encoder-map 'name
|
|
|
|
(compute-ssh-message-encoder type-byte-value field-type ...))
|
2011-08-11 04:25:28 +00:00
|
|
|
(hash-set! decoder-map type-byte-value
|
|
|
|
(compute-ssh-message-decoder name type-byte-value field-type ...))))))
|
|
|
|
|
2011-08-11 15:52:24 +00:00
|
|
|
(define-syntax t:boolean
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ #t) (lambda (input ks kf)
|
|
|
|
(bit-string-case input
|
|
|
|
([ v (rest :: binary) ]
|
|
|
|
(ks (not (zero? v)) rest))
|
|
|
|
(else (kf)))))
|
|
|
|
((_ #f) (lambda (v) (bit-string (if v 1 0))))))
|
|
|
|
|
2012-06-11 16:24:57 +00:00
|
|
|
(define-syntax t:packed-bytes
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ #t n) (lambda (input ks kf)
|
|
|
|
(bit-string-case input
|
|
|
|
([ (bs :: binary bytes n) (rest :: binary) ]
|
|
|
|
(ks (bit-string->bytes bs) rest))
|
|
|
|
(else (kf)))))
|
2012-06-11 20:11:22 +00:00
|
|
|
((_ #t) (lambda (input ks kf)
|
|
|
|
(bit-string-case input
|
|
|
|
([ (rest :: binary) ]
|
|
|
|
(ks (bit-string->bytes rest) #""))
|
|
|
|
(else (kf)))))
|
|
|
|
((_ #f n) (lambda (bs) (bit-string (bs :: binary))))
|
|
|
|
((_ #f) (lambda (bs) (bit-string (bs :: binary))))))
|
2012-06-11 16:24:57 +00:00
|
|
|
|
2011-08-11 15:52:24 +00:00
|
|
|
(define-syntax t:string
|
|
|
|
(syntax-rules ()
|
2011-10-20 18:19:29 +00:00
|
|
|
((_ #t #:pack) (lambda (input ks kf)
|
|
|
|
((t:string #t) input (lambda (v rest) (ks (bit-string->bytes v) rest)) kf)))
|
2011-08-11 15:52:24 +00:00
|
|
|
((_ #t) (lambda (input ks kf)
|
|
|
|
(bit-string-case input
|
|
|
|
([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
|
|
|
|
(ks body rest))
|
|
|
|
(else (kf)))))
|
2012-06-11 16:24:57 +00:00
|
|
|
((_ #f #:pack) (t:string #f)) ;; #:pack ignored on encoding
|
2011-08-11 15:52:24 +00:00
|
|
|
((_ #f) (lambda (bs)
|
|
|
|
(bit-string ((bytes-length (bit-string->bytes bs)) :: integer bits 32)
|
|
|
|
(bs :: binary))))))
|
|
|
|
|
|
|
|
(define-syntax t:mpint
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ #t) (lambda (input ks kf)
|
|
|
|
(bit-string-case input
|
|
|
|
([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
|
|
|
|
(ks (if (zero? (bit-string-length body)) 0 (bit-string->integer body #t #t))
|
|
|
|
rest))
|
|
|
|
(else (kf)))))
|
|
|
|
((_ #f) (lambda (n)
|
|
|
|
(let* ((width (mpint-width n))
|
|
|
|
(buf (integer->bit-string n (* 8 width) #t)))
|
|
|
|
(bit-string (width :: integer bits 32) (buf :: binary)))))))
|
|
|
|
|
|
|
|
(define-syntax t:name-list
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ #t) (lambda (input ks kf)
|
|
|
|
((t:string #t) input
|
|
|
|
(lambda (body rest) (ks (name-list->symbols body) rest))
|
|
|
|
kf)))
|
|
|
|
((_ #f) (lambda (ns)
|
|
|
|
((t:string #f) (symbols->name-list ns))))))
|
|
|
|
|
|
|
|
(define-for-syntax (codec-options field-type)
|
|
|
|
(syntax-case field-type (byte boolean uint32 uint64 string mpint name-list)
|
|
|
|
(byte #'(integer bits 8))
|
2012-06-11 16:24:57 +00:00
|
|
|
((byte n) #'((t:packed-bytes n)))
|
2011-08-11 15:52:24 +00:00
|
|
|
(boolean #'((t:boolean)))
|
|
|
|
(uint32 #'(integer bits 32))
|
|
|
|
(uint64 #'(integer bits 64))
|
2012-06-11 16:24:57 +00:00
|
|
|
(string #'((t:string #:pack)))
|
2011-08-11 15:52:24 +00:00
|
|
|
(mpint #'((t:mpint)))
|
2011-10-24 14:47:12 +00:00
|
|
|
(name-list #'((t:name-list)))
|
2012-06-11 20:11:22 +00:00
|
|
|
(extension #'((t:packed-bytes)))))
|
2011-08-11 15:52:24 +00:00
|
|
|
|
2011-08-11 04:25:28 +00:00
|
|
|
(define-syntax compute-ssh-message-encoder
|
|
|
|
(lambda (stx)
|
|
|
|
(syntax-case stx ()
|
|
|
|
((_ type-byte-value field-type ...)
|
|
|
|
#`(lambda (message)
|
|
|
|
(let ((vec (struct->vector message)))
|
|
|
|
#,(with-syntax (((field-spec ...)
|
|
|
|
(let ((type-list (syntax->list #'(field-type ...))))
|
2011-08-11 15:52:24 +00:00
|
|
|
(map (lambda (index type)
|
|
|
|
#`((vector-ref vec #,index) :: #,@(codec-options type)))
|
2011-08-11 04:25:28 +00:00
|
|
|
(iota (length type-list) 1)
|
|
|
|
type-list))))
|
|
|
|
#'(bit-string (type-byte-value :: integer bytes 1)
|
|
|
|
field-spec ...))))))))
|
|
|
|
|
|
|
|
(define-syntax compute-ssh-message-decoder
|
|
|
|
(lambda (stx)
|
|
|
|
(syntax-case stx ()
|
|
|
|
((_ struct-name type-byte-value field-type ...)
|
2011-08-11 15:52:24 +00:00
|
|
|
(with-syntax (((temp-name ...) (generate-temporaries #'(field-type ...)))
|
|
|
|
(((codec-option ...) ...)
|
|
|
|
(map codec-options (syntax->list #'(field-type ...)))))
|
2011-08-11 04:25:28 +00:00
|
|
|
#`(lambda (packet)
|
|
|
|
(bit-string-case packet
|
2011-08-11 15:52:24 +00:00
|
|
|
([ (= type-byte-value) (temp-name :: codec-option ...) ... ]
|
|
|
|
(struct-name temp-name ...)))))))))
|
2011-08-11 04:25:28 +00:00
|
|
|
|
|
|
|
(define (mpint-width n)
|
|
|
|
(if (zero? n)
|
|
|
|
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)
|
|
|
|
|
|
|
|
(define (symbols->name-list syms)
|
|
|
|
(bytes-join (map (lambda (s) (string->bytes/utf-8 (symbol->string s))) syms) #","))
|
|
|
|
|
|
|
|
(define (name-list->symbols bs)
|
|
|
|
(if (zero? (bit-string-length bs))
|
|
|
|
'()
|
|
|
|
(map string->symbol (regexp-split #rx"," (bytes->string/utf-8 (bit-string->bytes bs))))))
|
|
|
|
|
2012-05-15 18:22:00 +00:00
|
|
|
(struct test-message (value) #:prefab)
|
|
|
|
(let ((test-decode (compute-ssh-message-decoder test-message 123 mpint))
|
|
|
|
(test-encode (compute-ssh-message-encoder 123 mpint)))
|
2011-08-11 05:11:55 +00:00
|
|
|
(define (bidi-check msg enc-without-type-tag)
|
|
|
|
(let ((enc (bytes-append (bytes 123) enc-without-type-tag)))
|
2012-05-15 18:22:00 +00:00
|
|
|
(let ((msg-enc (bit-string->bytes (test-encode msg)))
|
2011-08-11 05:11:55 +00:00
|
|
|
(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))
|
|
|
|
|
2011-08-11 04:25:28 +00:00
|
|
|
(define-ssh-message-type ssh-msg-kexinit SSH_MSG_KEXINIT
|
|
|
|
((byte 16) cookie)
|
|
|
|
(name-list kex_algorithms)
|
|
|
|
(name-list server_host_key_algorithms)
|
|
|
|
(name-list encryption_algorithms_client_to_server)
|
|
|
|
(name-list encryption_algorithms_server_to_client)
|
|
|
|
(name-list mac_algorithms_client_to_server)
|
|
|
|
(name-list mac_algorithms_server_to_client)
|
|
|
|
(name-list compression_algorithms_client_to_server)
|
|
|
|
(name-list compression_algorithms_server_to_client)
|
|
|
|
(name-list languages_client_to_server)
|
|
|
|
(name-list languages_server_to_client)
|
|
|
|
(boolean first_kex_packet_follows)
|
|
|
|
(uint32 reserved))
|
2011-08-16 06:46:45 +00:00
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-kexdh-init SSH_MSG_KEXDH_INIT
|
|
|
|
(mpint e))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-kexdh-reply SSH_MSG_KEXDH_REPLY
|
|
|
|
(string host-key)
|
|
|
|
(mpint f)
|
|
|
|
(string h-signature))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-disconnect SSH_MSG_DISCONNECT
|
|
|
|
(uint32 reason-code)
|
|
|
|
(string description)
|
2011-11-02 22:52:39 +00:00
|
|
|
;; TODO: OpenSSH 5.3p1 Debian-3ubuntu7 25 Mar 2009 (from lucid)
|
|
|
|
;; sends SSH_MSG_DISCONNECT without the language-tag field! In
|
|
|
|
;; particular, when I press ^D to terminate my session, I get
|
|
|
|
;; #"\1\0\0\0\v\0\0\0\24disconnected by user".
|
2011-08-16 06:46:45 +00:00
|
|
|
(string language-tag))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-unimplemented SSH_MSG_UNIMPLEMENTED
|
|
|
|
(uint32 sequence-number))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-newkeys SSH_MSG_NEWKEYS)
|
|
|
|
|
2011-10-18 01:13:46 +00:00
|
|
|
(define-ssh-message-type ssh-msg-debug SSH_MSG_DEBUG
|
|
|
|
(boolean always-display?)
|
|
|
|
(string message)
|
|
|
|
(string language-tag))
|
|
|
|
|
2011-08-16 06:46:45 +00:00
|
|
|
(define-ssh-message-type ssh-msg-ignore SSH_MSG_IGNORE
|
|
|
|
(string data))
|
2011-10-24 01:26:13 +00:00
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-service-request SSH_MSG_SERVICE_REQUEST
|
|
|
|
(string service-name))
|
2011-10-24 14:47:12 +00:00
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-service-accept SSH_MSG_SERVICE_ACCEPT
|
|
|
|
(string service-name))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-userauth-request SSH_MSG_USERAUTH_REQUEST
|
|
|
|
(string user-name)
|
|
|
|
(string service-name)
|
|
|
|
(string method-name)
|
|
|
|
(extension method-specific-fields))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-userauth-failure SSH_MSG_USERAUTH_FAILURE
|
|
|
|
(name-list continuable-authentications)
|
|
|
|
(boolean partial-success?))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-userauth-success SSH_MSG_USERAUTH_SUCCESS)
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-global-request SSH_MSG_GLOBAL_REQUEST
|
|
|
|
(string request-name)
|
|
|
|
(boolean want-reply?)
|
|
|
|
(extension data))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-request-success SSH_MSG_REQUEST_SUCCESS
|
|
|
|
(extension data))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-request-failure SSH_MSG_REQUEST_FAILURE)
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-open SSH_MSG_CHANNEL_OPEN
|
|
|
|
(string channel-type)
|
|
|
|
(uint32 sender-channel)
|
|
|
|
(uint32 initial-window-size)
|
|
|
|
(uint32 maximum-packet-size)
|
|
|
|
(extension data))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-open-confirmation SSH_MSG_CHANNEL_OPEN_CONFIRMATION
|
|
|
|
(uint32 recipient-channel)
|
|
|
|
(uint32 sender-channel)
|
|
|
|
(uint32 initial-window-size)
|
|
|
|
(uint32 maximum-packet-size)
|
|
|
|
(extension data))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-open-failure SSH_MSG_CHANNEL_OPEN_FAILURE
|
|
|
|
(uint32 recipient-channel)
|
|
|
|
(uint32 reason)
|
|
|
|
(string description)
|
|
|
|
(string language))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-window-adjust SSH_MSG_CHANNEL_WINDOW_ADJUST
|
|
|
|
(uint32 recipient-channel)
|
|
|
|
(uint32 bytes))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-data SSH_MSG_CHANNEL_DATA
|
|
|
|
(uint32 recipient-channel)
|
|
|
|
(string data))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-extended-data SSH_MSG_CHANNEL_EXTENDED_DATA
|
|
|
|
(uint32 recipient-channel)
|
|
|
|
(uint32 type-code)
|
|
|
|
(string data))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-eof SSH_MSG_CHANNEL_EOF
|
|
|
|
(uint32 recipient-channel))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-close SSH_MSG_CHANNEL_CLOSE
|
|
|
|
(uint32 recipient-channel))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-request SSH_MSG_CHANNEL_REQUEST
|
|
|
|
(uint32 recipient-channel)
|
|
|
|
(string type)
|
|
|
|
(boolean want-reply?)
|
|
|
|
(extension data))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-success SSH_MSG_CHANNEL_SUCCESS
|
|
|
|
(uint32 recipient-channel))
|
|
|
|
|
|
|
|
(define-ssh-message-type ssh-msg-channel-failure SSH_MSG_CHANNEL_FAILURE
|
|
|
|
(uint32 recipient-channel))
|