Beginnings of codec and transport.
This commit is contained in:
Tony Garnock-Jones
parent
19774e7bf1
commit
09a45e12a2
|
|
@ -0,0 +1,168 @@
|
|||
#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)
|
||||
|
||||
(define decoder-map (make-hasheqv))
|
||||
|
||||
(define-values (prop:ssh-message-encoder ssh-message-encoder? ssh-message-encoder)
|
||||
(make-struct-type-property 'ssh-message-encoder))
|
||||
|
||||
(define (ssh-message-decode packet)
|
||||
(let ((type-code (bytes-ref packet 0)))
|
||||
((hash-ref decoder-map
|
||||
type-code
|
||||
(lambda () (error 'ssh-message-decode
|
||||
"Unknown message packet type number ~v"
|
||||
type-code)))
|
||||
packet)))
|
||||
|
||||
(define (ssh-message-encode m)
|
||||
((ssh-message-encoder m) m))
|
||||
|
||||
(define-syntax define-ssh-message-type
|
||||
(syntax-rules ()
|
||||
((_ name type-byte-value (field-type field-name) ...)
|
||||
(begin
|
||||
(provide (struct-out name))
|
||||
(struct name (field-name ...)
|
||||
#:transparent
|
||||
#:property prop:ssh-message-encoder
|
||||
(compute-ssh-message-encoder type-byte-value field-type ...))
|
||||
(hash-set! decoder-map type-byte-value
|
||||
(compute-ssh-message-decoder name type-byte-value field-type ...))))))
|
||||
|
||||
(define-syntax compute-ssh-message-encoder
|
||||
(lambda (stx)
|
||||
(define (encoder-field index vec field-type)
|
||||
(syntax-case field-type (byte boolean uint32 uint64 string mpint name-list)
|
||||
(byte
|
||||
#`(vector-ref #,vec #,index))
|
||||
((byte n)
|
||||
#`((vector-ref #,vec #,index) :: binary bytes n))
|
||||
(boolean
|
||||
#`(if (vector-ref #,vec #,index) 1 0))
|
||||
(uint32
|
||||
#`((vector-ref #,vec #,index) :: integer bits 32))
|
||||
(uint64
|
||||
#`((vector-ref #,vec #,index) :: integer bits 64))
|
||||
(string
|
||||
#`((let ((v (vector-ref #,vec #,index)))
|
||||
(bit-string ((bytes-length v) :: integer bits 32)
|
||||
(v :: binary))) :: binary))
|
||||
(mpint
|
||||
#`((let* ((v (vector-ref #,vec #,index))
|
||||
(width (mpint-width v))
|
||||
(buf (integer->bit-string v (* 8 width) #t)))
|
||||
(bit-string (width :: integer bits 32)
|
||||
(buf :: binary))) :: binary))
|
||||
(name-list
|
||||
#`((let ((v (symbols->name-list (vector-ref #,vec #,index))))
|
||||
(bit-string ((quotient (bit-string-length v) 8) :: integer bits 32)
|
||||
(v :: binary))) :: binary))))
|
||||
(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 ...))))
|
||||
(map (lambda (index type) (encoder-field index #'vec type))
|
||||
(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)
|
||||
(define (field-extractor temp-name field-type)
|
||||
(syntax->list
|
||||
(syntax-case field-type (byte boolean uint32 uint64 string mpint name-list)
|
||||
(byte
|
||||
#`(#,temp-name))
|
||||
((byte n)
|
||||
#`((#,temp-name :: binary bytes n)))
|
||||
(boolean
|
||||
#`(#,temp-name))
|
||||
(uint32
|
||||
#`((#,temp-name :: integer bits 32)))
|
||||
(uint64
|
||||
#`((#,temp-name :: integer bits 64)))
|
||||
(string
|
||||
(let ((length-name (car (generate-temporaries (list temp-name)))))
|
||||
#`((#,length-name :: integer bits 32)
|
||||
(#,temp-name :: binary bytes #,length-name))))
|
||||
(mpint
|
||||
(let ((length-name (car (generate-temporaries (list temp-name)))))
|
||||
#`((#,@length-name :: integer bits 32)
|
||||
(#,temp-name :: binary bytes #,length-name))))
|
||||
(name-list
|
||||
(let ((length-name (car (generate-temporaries (list temp-name)))))
|
||||
#`((#,length-name :: integer bits 32)
|
||||
(#,temp-name :: binary bytes #,length-name)))))))
|
||||
(define (field-transformer temp-name field-type)
|
||||
(syntax-case field-type (byte boolean uint32 uint64 string mpint name-list)
|
||||
((byte n) #`(bit-string->bytes #,temp-name))
|
||||
(boolean #`(not (zero? #,temp-name)))
|
||||
(string #`(bit-string->bytes #,temp-name))
|
||||
(mpint #`(bit-string->integer #,temp-name))
|
||||
(name-list #`(name-list->symbols #,temp-name))
|
||||
(else temp-name)))
|
||||
(syntax-case stx ()
|
||||
((_ struct-name type-byte-value field-type ...)
|
||||
(let* ((field-types (syntax->list #'(field-type ...)))
|
||||
(temp-names (generate-temporaries field-types)))
|
||||
#`(lambda (packet)
|
||||
(bit-string-case packet
|
||||
(( type-byte-value
|
||||
#,@(append* (map field-extractor temp-names field-types)))
|
||||
(struct-name #,@(map field-transformer temp-names field-types))))))))))
|
||||
|
||||
(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))))))
|
||||
|
||||
(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))
|
||||
|
|
@ -0,0 +1,138 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (planet tonyg/bitsyntax))
|
||||
(require (planet vyzo/crypto:2:3))
|
||||
|
||||
(require rackunit)
|
||||
(require "safe-io.rkt")
|
||||
(require "ssh-numbers.rkt")
|
||||
(require "ssh-message-types.rkt")
|
||||
|
||||
(define identification-recogniser #rx"^SSH-")
|
||||
(define (identification-line? str)
|
||||
(regexp-match identification-recogniser str))
|
||||
|
||||
(define required-server-identification-regex (make-parameter #rx"^SSH-2\\.0-.*"))
|
||||
|
||||
(define client-preamble-lines (make-parameter '()))
|
||||
(define client-identification-string (make-parameter "SSH-2.0-RacketSSH_0.0"))
|
||||
|
||||
(define (send-preamble-and-identification! out)
|
||||
(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 (client-identification-string) out)
|
||||
(display "\r\n" out)
|
||||
(flush-output out))
|
||||
|
||||
(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 (check-packet-length! actual-length limit block-size)
|
||||
(when (> actual-length limit)
|
||||
(error 'check-packet-length!
|
||||
"Packet of length ~v is longer than packet limit ~v"
|
||||
actual-length
|
||||
limit))
|
||||
(when (not (zero? (modulo actual-length block-size)))
|
||||
(error 'check-packet-length!
|
||||
"Packet of length ~v is not a multiple of block size ~v"
|
||||
actual-length
|
||||
block-size)))
|
||||
|
||||
(define (read-bytes/decrypt count in decryptor)
|
||||
(let ((encrypted (read-bytes count in)))
|
||||
(if (eof-object? encrypted)
|
||||
encrypted
|
||||
(decryptor encrypted))))
|
||||
|
||||
;; 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
|
||||
cipher
|
||||
sequence-number
|
||||
check-mac!
|
||||
packet-size-limit)
|
||||
(define first-block-size (if cipher (cipher-block-size cipher) 8))
|
||||
(define subsequent-block-size (if cipher first-block-size 1))
|
||||
(define decryptor (if cipher (lambda (blocks) (cipher-update! cipher blocks)) values))
|
||||
(define first-block (read-bytes/decrypt first-block-size in decryptor))
|
||||
(if (eof-object? first-block)
|
||||
first-block
|
||||
(let* ((packet-length (integer-bytes->integer first-block #f #t 0 4)))
|
||||
(check-packet-length! packet-length packet-size-limit subsequent-block-size)
|
||||
(let* ((padding-length (bytes-ref first-block 4))
|
||||
(payload-length (- packet-length padding-length 1))
|
||||
(remaining-to-read (- packet-length (bytes-length first-block))))
|
||||
(define (read-packet-trailer packet)
|
||||
(check-mac! sequence-number packet in)
|
||||
(subbytes packet 5 (+ 5 payload-length)))
|
||||
(if (positive? remaining-to-read)
|
||||
(let ((trailing-blocks (read-bytes/decrypt remaining-to-read in decryptor)))
|
||||
(if (eof-object? trailing-blocks)
|
||||
trailing-blocks
|
||||
(read-packet-trailer (bytes-append first-block trailing-blocks))))
|
||||
(read-packet-trailer first-block))))))
|
||||
|
||||
(define (null-mac-checker sequence-number packet in)
|
||||
'ok)
|
||||
|
||||
(define (ssh-session in out seed packet-handler)
|
||||
(send-preamble-and-identification! out)
|
||||
(let ((server-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-server-identification-regex)
|
||||
server-identification-string))
|
||||
(error 'ssh-session "Received invalid identification ~v from peer"
|
||||
server-identification-string))
|
||||
|
||||
(define (write-packet! . args)
|
||||
(error 'write-packet "Unimplemented"))
|
||||
|
||||
(define result
|
||||
(let loop ((seed seed)
|
||||
(sequence-number 0)
|
||||
(cipher #f)
|
||||
(check-mac! null-mac-checker))
|
||||
(let ((packet (read-packet in cipher sequence-number check-mac! 65536)))
|
||||
(if (eof-object? packet)
|
||||
seed
|
||||
(packet-handler seed
|
||||
packet
|
||||
write-packet!
|
||||
(lambda (new-seed) (loop new-seed
|
||||
(+ sequence-number 1)
|
||||
cipher
|
||||
check-mac!))
|
||||
(lambda args
|
||||
(error 'rekey "Unimplemented")))))))
|
||||
|
||||
(close-input-port in)
|
||||
(close-output-port out)
|
||||
result))
|
||||
|
||||
(require racket/tcp)
|
||||
(require racket/pretty)
|
||||
(define (t)
|
||||
(let-values (((i o) (tcp-connect "localhost" 22)))
|
||||
(ssh-session i o #f
|
||||
(lambda (seed packet write-packet! continue-reading rekey)
|
||||
(pretty-print packet)
|
||||
(pretty-print (ssh-message-decode packet))
|
||||
(continue-reading seed)))))
|
||||
(t)
|
||||
Loading…
Reference in New Issue