Initial commit from racket-ssh
This commit is contained in:
commit
f246f6cd15
|
@ -0,0 +1 @@
|
|||
compiled/
|
|
@ -0,0 +1,5 @@
|
|||
all:
|
||||
raco make new-server.rkt
|
||||
|
||||
clean:
|
||||
find . -name compiled -type d | xargs rm -rf
|
|
@ -0,0 +1,16 @@
|
|||
- Check VERY thoroughly for memory leaks in our usage of the FFI over OpenSSL.
|
||||
|
||||
- Figure out the following, observed while flooding the server with
|
||||
cat /dev/zero piped into ssh localhost -p 2322:
|
||||
|
||||
Seg fault (internal error) at 0x4
|
||||
Bus error
|
||||
|
||||
After a while it crashes out like that. Or seems to deadlock.
|
||||
|
||||
- Figure out what the rules for packet size limit really are. Is it
|
||||
payload limit or what? Why does OpenSSH give us these large packets
|
||||
sometimes?
|
||||
|
||||
- Buffer outbound traffic during rekey so we don't try to talk between
|
||||
KEXINIT and NEWKEYS
|
|
@ -0,0 +1,64 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Provide AES CTR mode, since OpenSSL's EVP support for AES CTR mode
|
||||
;; is still ifdef'd out.
|
||||
|
||||
(provide start-aes-ctr
|
||||
aes-ctr-process!)
|
||||
|
||||
(require ffi/unsafe)
|
||||
(require ffi/unsafe/define)
|
||||
(require openssl/libcrypto)
|
||||
|
||||
(define _AES_KEY-pointer _pointer)
|
||||
|
||||
(define AES_BLOCK_SIZE 16)
|
||||
(define sizeof-AES_KEY 244) ;; TODO: figure out a good way to get this
|
||||
;; from the header file or the library
|
||||
;; itself
|
||||
|
||||
(define-ffi-definer define-crypto libcrypto
|
||||
#:default-make-fail make-not-available)
|
||||
|
||||
(define-crypto AES_set_encrypt_key (_fun _pointer _int _AES_KEY-pointer -> _int))
|
||||
;;(define-crypto AES_set_decrypt_key (_fun _pointer _int _AES_KEY-pointer -> _int))
|
||||
|
||||
(define-crypto AES_ctr128_encrypt
|
||||
(_fun _pointer ;; in
|
||||
_pointer ;; out
|
||||
_long ;; length
|
||||
_AES_KEY-pointer ;; key
|
||||
_pointer ;; ivec, AES_BLOCK_SIZE bytes
|
||||
_pointer ;; ecount_buf, AES_BLOCK_SIZE bytes
|
||||
_pointer ;; int pointer, the "num" field of the ongoing state (??)
|
||||
-> _void))
|
||||
|
||||
(struct aes-ctr-state (key ivec ecount num) #:transparent)
|
||||
|
||||
(define (start-aes-ctr key initialization-vector)
|
||||
(let ((key-buffer (malloc sizeof-AES_KEY))
|
||||
(ivec (make-bytes AES_BLOCK_SIZE))
|
||||
(ecount (make-bytes AES_BLOCK_SIZE))
|
||||
(num (make-bytes (ctype-sizeof _int))))
|
||||
(AES_set_encrypt_key key
|
||||
(* 8 (bytes-length key)) ;; measured in bits
|
||||
key-buffer)
|
||||
(bytes-copy! ivec 0 initialization-vector 0 AES_BLOCK_SIZE)
|
||||
(bytes-fill! ecount 0)
|
||||
(bytes-fill! num 0)
|
||||
(aes-ctr-state key-buffer
|
||||
ivec
|
||||
ecount
|
||||
num)))
|
||||
|
||||
(define (aes-ctr-process! state input-block)
|
||||
(define block-length (bytes-length input-block))
|
||||
(define output-block (make-bytes block-length))
|
||||
(AES_ctr128_encrypt input-block
|
||||
output-block
|
||||
block-length
|
||||
(aes-ctr-state-key state)
|
||||
(aes-ctr-state-ivec state)
|
||||
(aes-ctr-state-ecount state)
|
||||
(aes-ctr-state-num state))
|
||||
output-block)
|
|
@ -0,0 +1,164 @@
|
|||
#lang racket/base
|
||||
;; A very small subset of ASN.1 BER (from ITU-T X.690), suitable for
|
||||
;; en- and decoding public-key data for the ssh-rsa and ssh-dss
|
||||
;; algorithms.
|
||||
|
||||
(require racket/match)
|
||||
(require (planet tonyg/bitsyntax))
|
||||
|
||||
(provide t:long-ber-tag
|
||||
t:ber-length-indicator
|
||||
|
||||
asn1-ber-decode-all
|
||||
asn1-ber-decode
|
||||
asn1-ber-encode)
|
||||
|
||||
(define-syntax t:long-ber-tag
|
||||
(syntax-rules ()
|
||||
((_ #t input ks kf) (read-long-tag input ks kf))
|
||||
((_ #f v) (write-long-tag v))))
|
||||
|
||||
(define (read-long-tag input ks kf)
|
||||
(let loop ((acc 0)
|
||||
(input input))
|
||||
(bit-string-case input
|
||||
([ (= 1 :: bits 1)
|
||||
(x :: bits 7)
|
||||
(rest :: binary) ]
|
||||
(loop (+ x (arithmetic-shift acc 7)) rest))
|
||||
([ (= 0 :: bits 1)
|
||||
(x :: bits 7)
|
||||
(rest :: binary) ]
|
||||
(when (not (zero? x)))
|
||||
(ks (+ x (arithmetic-shift acc 7)) rest))
|
||||
(else (kf)))))
|
||||
|
||||
(define (write-long-tag v)
|
||||
(list->bytes
|
||||
(reverse-and-set-high-bits
|
||||
(let loop ((v v))
|
||||
(if (< v 128)
|
||||
(list v)
|
||||
(cons (bitwise-and v 127)
|
||||
(loop (arithmetic-shift v -7))))))))
|
||||
|
||||
(define (reverse-and-set-high-bits bs)
|
||||
(let loop ((acc (list (car bs)))
|
||||
(bs (cdr bs)))
|
||||
(if (null? bs)
|
||||
acc
|
||||
(loop (cons (bitwise-ior 128 (car bs)) acc) (cdr bs)))))
|
||||
|
||||
(define-syntax t:ber-length-indicator
|
||||
(syntax-rules ()
|
||||
((_ #t input ks0 kf)
|
||||
(let ((ks ks0)) ;; avoid code explosion
|
||||
(bit-string-case input
|
||||
([ (= 128 :: bits 8)
|
||||
(rest :: binary) ]
|
||||
(ks 'indefinite rest))
|
||||
([ (= 0 :: bits 1)
|
||||
(len :: bits 7)
|
||||
(rest :: binary) ]
|
||||
(ks len rest))
|
||||
([ (= 1 :: bits 1)
|
||||
(lenlen :: bits 7)
|
||||
(len :: integer bytes lenlen)
|
||||
(rest :: binary) ]
|
||||
(when (not (= lenlen 127))) ;; restriction from section 8.1.3.5
|
||||
(ks len rest))
|
||||
(else (kf)))))
|
||||
((_ #f len)
|
||||
(cond
|
||||
((eq? len 'indefinite)
|
||||
(bytes 128))
|
||||
((< len 128)
|
||||
(bytes len))
|
||||
(else
|
||||
(let ((lenlen (quotient (+ 7 (integer-length len)) 8)))
|
||||
(bit-string (1 :: bits 1)
|
||||
(lenlen :: bits 7)
|
||||
(len :: integer bytes lenlen))))))))
|
||||
|
||||
(define (asn1-ber-decode-all packet)
|
||||
(let-values (((value rest) (asn1-ber-decode packet)))
|
||||
(if (equal? rest #"")
|
||||
value
|
||||
(error 'asn1-ber-decode-all "Trailing bytes present in encoded ASN.1 BER term"))))
|
||||
|
||||
(define (asn1-ber-decode packet)
|
||||
(asn1-ber-decode* packet (lambda (class tag value rest)
|
||||
(values (list class tag value)
|
||||
(bit-string->bytes rest)))))
|
||||
|
||||
(define (asn1-ber-decode* packet k)
|
||||
(bit-string-case packet
|
||||
;; Tag with number >= 31
|
||||
([ (class :: bits 2)
|
||||
(constructed :: bits 1)
|
||||
(= 31 :: bits 5)
|
||||
(tag :: (t:long-ber-tag))
|
||||
(length :: (t:ber-length-indicator))
|
||||
(rest :: binary) ]
|
||||
(asn1-ber-decode-contents class constructed tag length rest k))
|
||||
([ (class :: bits 2)
|
||||
(constructed :: bits 1)
|
||||
(tag :: bits 5)
|
||||
(length :: (t:ber-length-indicator))
|
||||
(rest :: binary) ]
|
||||
(asn1-ber-decode-contents class constructed tag length rest k))))
|
||||
|
||||
(define (asn1-ber-decode-contents class constructed tag length rest k)
|
||||
(cond
|
||||
((= constructed 1)
|
||||
(define indefinite? (eq? length 'indefinite))
|
||||
(define block (if indefinite? rest (sub-bit-string rest 0 (* length 8))))
|
||||
(asn1-ber-decode-seq block indefinite? (lambda (seq rest) (k class tag seq rest))))
|
||||
((= constructed 0)
|
||||
(bit-string-case rest
|
||||
([ (block :: binary bytes length)
|
||||
(rest :: binary) ]
|
||||
(k class tag (bit-string->bytes block) rest))))))
|
||||
|
||||
(define (asn1-ber-decode-seq packet indefinite? k)
|
||||
(let loop ((rest packet)
|
||||
(k k))
|
||||
(if (and (bit-string-empty? rest)
|
||||
(not indefinite?))
|
||||
(k '() rest)
|
||||
(asn1-ber-decode* rest
|
||||
(lambda (class tag value rest)
|
||||
(if (and indefinite?
|
||||
(= class 0)
|
||||
(= tag 0)
|
||||
(equal? value #""))
|
||||
(k '() rest)
|
||||
(loop rest
|
||||
(lambda (seq rest)
|
||||
(k (cons (list class tag value) seq) rest)))))))))
|
||||
|
||||
(define (asn1-ber-encode entry)
|
||||
(bit-string->bytes (asn1-ber-encode* entry)))
|
||||
|
||||
(define (asn1-ber-encode* entry)
|
||||
(match entry
|
||||
(`(,class ,tag ,value)
|
||||
(if (list? value)
|
||||
(let* ((encoded-values (map asn1-ber-encode* value))
|
||||
(content-octets (foldr bit-string-append #"" encoded-values))
|
||||
(content-length (quotient (bit-string-length content-octets) 8)))
|
||||
(bit-string (class :: bits 2)
|
||||
(1 :: bits 1) ;; constructed
|
||||
((asn1-ber-encode-tag tag) :: binary)
|
||||
(content-length :: (t:ber-length-indicator))
|
||||
(content-octets :: binary bytes content-length)))
|
||||
(bit-string (class :: bits 2)
|
||||
(0 :: bits 1) ;; not constructed
|
||||
((asn1-ber-encode-tag tag) :: binary)
|
||||
((bytes-length value) :: (t:ber-length-indicator))
|
||||
(value :: binary))))))
|
||||
|
||||
(define (asn1-ber-encode-tag tag)
|
||||
(if (>= tag 31)
|
||||
(bit-string (31 :: bits 5) (tag :: (t:long-ber-tag)))
|
||||
(bit-string (tag :: bits 5))))
|
|
@ -0,0 +1,95 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/port)
|
||||
|
||||
(provide cook-io)
|
||||
|
||||
(define clear-to-eol "\033[2K")
|
||||
(define kill-line (string-append "\r" clear-to-eol))
|
||||
|
||||
(struct buffer (chars consume-next-linefeed?) #:transparent)
|
||||
|
||||
(define (buffer-empty? b)
|
||||
(null? (buffer-chars b)))
|
||||
|
||||
(define (buffer-adjust b new-chars)
|
||||
(struct-copy buffer b
|
||||
[chars new-chars]
|
||||
[consume-next-linefeed? #f]))
|
||||
|
||||
(define (buffer-contents b)
|
||||
(list->string (reverse (buffer-chars b))))
|
||||
|
||||
(define (update-buffer b key prompt k-eof k-complete k-ongoing)
|
||||
(case key
|
||||
((#\backspace #\rubout) ;; backspace = ^H = code 8; delete = code 127
|
||||
(if (buffer-empty? b)
|
||||
(k-ongoing b "")
|
||||
(k-ongoing (buffer-adjust b (cdr (buffer-chars b))) "\b \b")))
|
||||
((#\return) (k-complete (buffer-contents b) (buffer '() #t)))
|
||||
((#\newline) (if (buffer-consume-next-linefeed? b)
|
||||
(k-ongoing (struct-copy buffer b [consume-next-linefeed? #f]) "")
|
||||
(k-complete (buffer-contents b) (buffer '() #f))))
|
||||
((#\page) (k-ongoing b (string-append kill-line prompt (buffer-contents b))))
|
||||
((#\004) ;; control-D, UNIX EOF
|
||||
(if (buffer-empty? b)
|
||||
(k-eof)
|
||||
(k-ongoing b "")))
|
||||
((#\033) ;; escape
|
||||
(k-ongoing (buffer '() #f) (string-append kill-line prompt)))
|
||||
(else (if (char-iso-control? key)
|
||||
(k-ongoing b "")
|
||||
(k-ongoing (buffer-adjust b (cons key (buffer-chars b))) (string key))))))
|
||||
|
||||
(define (cook-io raw-in raw-out prompt)
|
||||
(define-values (cooked-in cooked-out) (make-pipe))
|
||||
(define (close-ports)
|
||||
(close-output-port cooked-out) ;; signal to our reader that we're not sending more
|
||||
(close-input-port raw-in)) ;; signal to upstream that we are done reading
|
||||
(thread
|
||||
(lambda ()
|
||||
(define input-buffer (make-bytes 4096))
|
||||
(let loop ((b (buffer '() #f)))
|
||||
(if (port-closed? cooked-in)
|
||||
;; The ultimate reader of our cooked output has closed
|
||||
;; their input port. We are therefore done.
|
||||
(close-ports)
|
||||
;; TODO: remove polling for port-closed when we get port-closed-evt
|
||||
(let ((count (sync/timeout 0.5 (read-bytes-avail!-evt input-buffer raw-in))))
|
||||
(cond
|
||||
((eof-object? count) ;; end-of-file on input
|
||||
(close-ports))
|
||||
((eq? count #f) ;; timeout - poll to see if cooked-out has been closed
|
||||
(loop b))
|
||||
(else ;; a number - count of bytes read
|
||||
(let process-bytes ((i 0) (b b))
|
||||
(if (>= i count)
|
||||
(loop b)
|
||||
(update-buffer b (integer->char (bytes-ref input-buffer i)) prompt
|
||||
close-ports
|
||||
(lambda (line new-b)
|
||||
(with-handlers ((exn:fail? void)) ;; ignore write errors
|
||||
(write-string "\r\n" raw-out))
|
||||
(write-string line cooked-out)
|
||||
(newline cooked-out)
|
||||
(process-bytes (+ i 1) new-b))
|
||||
(lambda (new-b feedback)
|
||||
(with-handlers ((exn:fail? void)) ;; ignore write errors
|
||||
(write-string feedback raw-out))
|
||||
(process-bytes (+ i 1) new-b))))))))))))
|
||||
(values cooked-in (cook-output raw-out)))
|
||||
|
||||
(define (cook-output raw-out)
|
||||
(define-values (cooked-in cooked-out) (make-pipe))
|
||||
(thread
|
||||
(lambda ()
|
||||
(define buffer (make-bytes 4096))
|
||||
(let loop ()
|
||||
(define count (read-bytes-avail! buffer cooked-in))
|
||||
(if (eof-object? count)
|
||||
(begin (close-input-port cooked-in)
|
||||
(close-output-port raw-out))
|
||||
(let ((raw-data (regexp-replace* #"\n" (subbytes buffer 0 count) #"\r\n")))
|
||||
(write-bytes raw-data raw-out)
|
||||
(loop))))))
|
||||
cooked-out)
|
|
@ -0,0 +1,75 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide make-queue
|
||||
queue?
|
||||
enqueue
|
||||
enqueue-all
|
||||
dequeue
|
||||
list->queue
|
||||
queue->list
|
||||
queue-length
|
||||
queue-empty?
|
||||
queue-append
|
||||
queue-extract)
|
||||
|
||||
(struct queue (head tail) #:transparent)
|
||||
|
||||
(define (make-queue)
|
||||
(queue '() '()))
|
||||
|
||||
(define (enqueue q v)
|
||||
(queue (queue-head q)
|
||||
(cons v (queue-tail q))))
|
||||
|
||||
(define (enqueue-all q v)
|
||||
(queue (queue-head q)
|
||||
(append (reverse v) (queue-tail q))))
|
||||
|
||||
(define (shuffle q)
|
||||
(if (null? (queue-head q))
|
||||
(queue (reverse (queue-tail q)) '())
|
||||
q))
|
||||
|
||||
(define (dequeue q)
|
||||
(let ((q1 (shuffle q)))
|
||||
(values (car (queue-head q1))
|
||||
(queue (cdr (queue-head q1)) (queue-tail q1)))))
|
||||
|
||||
(define (list->queue xs)
|
||||
(queue xs '()))
|
||||
|
||||
(define (queue->list q)
|
||||
(append (queue-head q) (reverse (queue-tail q))))
|
||||
|
||||
(define (queue-length q)
|
||||
(+ (length (queue-head q))
|
||||
(length (queue-tail q))))
|
||||
|
||||
(define (queue-empty? q)
|
||||
(and (null? (queue-head q))
|
||||
(null? (queue-tail q))))
|
||||
|
||||
(define (queue-append q1 q2)
|
||||
(queue (append (queue-head q1)
|
||||
(reverse (queue-tail q1))
|
||||
(queue-head q2))
|
||||
(queue-tail q2)))
|
||||
|
||||
(define (queue-extract q predicate [default-value #f])
|
||||
(let search-head ((head (queue-head q))
|
||||
(rejected-head-rev '()))
|
||||
(cond
|
||||
((null? head) (let search-tail ((tail (reverse (queue-tail q)))
|
||||
(rejected-tail-rev '()))
|
||||
(cond
|
||||
((null? tail) (values default-value q))
|
||||
((predicate (car tail)) (values (car tail)
|
||||
(queue (queue-head q)
|
||||
(append (reverse (cdr tail))
|
||||
rejected-tail-rev))))
|
||||
(else (search-tail (cdr tail) (cons (car tail) rejected-tail-rev))))))
|
||||
((predicate (car head)) (values (car head)
|
||||
(queue (append (reverse rejected-head-rev)
|
||||
(cdr head))
|
||||
(queue-tail q))))
|
||||
(else (search-head (cdr head) (cons (car head) rejected-head-rev))))))
|
|
@ -0,0 +1,35 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide define-mapping)
|
||||
|
||||
(define-syntax check-defaults
|
||||
(syntax-rules ()
|
||||
((_ fn bn fd bd #:forward-default new-fd rest ...)
|
||||
(check-defaults fn bn new-fd bd rest ...))
|
||||
((_ fn bn fd bd #:backward-default new-bd rest ...)
|
||||
(check-defaults fn bn fd new-bd rest ...))
|
||||
((_ fn bn fd bd (lhs rhs) ...)
|
||||
(begin
|
||||
(define (fn l)
|
||||
(case l
|
||||
((lhs) 'rhs) ...
|
||||
(else (fd l))))
|
||||
(define (bn r)
|
||||
(case r
|
||||
((rhs) 'lhs) ...
|
||||
(else (bd r))))))))
|
||||
|
||||
(define (die-with-mapping-name n)
|
||||
(lambda (v)
|
||||
(raise (exn:fail:contract
|
||||
(format "~v: Mapping not found for ~v" n v)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
(define-syntax define-mapping
|
||||
(syntax-rules ()
|
||||
((_ forward-name backward-name rest ...)
|
||||
(check-defaults forward-name
|
||||
backward-name
|
||||
(die-with-mapping-name 'forward-name)
|
||||
(die-with-mapping-name 'backward-name)
|
||||
rest ...))))
|
|
@ -0,0 +1,12 @@
|
|||
#lang racket/base
|
||||
;; Reexport racket-matrix module contents.
|
||||
|
||||
(require marketplace/sugar-untyped)
|
||||
(require marketplace/drivers/tcp)
|
||||
(require marketplace/drivers/timer-untyped)
|
||||
(require marketplace/drivers/event-relay)
|
||||
|
||||
(provide (all-from-out marketplace/sugar-untyped))
|
||||
(provide (all-from-out marketplace/drivers/tcp))
|
||||
(provide (all-from-out marketplace/drivers/timer-untyped))
|
||||
(provide (all-from-out marketplace/drivers/event-relay))
|
|
@ -0,0 +1,284 @@
|
|||
#lang racket/base
|
||||
;; (Temporary) example client and server
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/contract)
|
||||
(require (only-in racket/port peek-bytes-avail!-evt))
|
||||
(require "cook-port.rkt")
|
||||
(require "sandboxes.rkt")
|
||||
|
||||
(require "ssh-numbers.rkt")
|
||||
(require "ssh-transport.rkt")
|
||||
(require "ssh-session.rkt")
|
||||
(require "ssh-channel.rkt")
|
||||
(require "ssh-message-types.rkt")
|
||||
(require "ssh-exceptions.rkt")
|
||||
(require "marketplace-support.rkt")
|
||||
|
||||
(define (main)
|
||||
(ground-vm (timer-driver)
|
||||
(tcp-driver)
|
||||
(tcp-spy)
|
||||
(spawn #:debug-name 'ssh-tcp-listener #:child listener)))
|
||||
|
||||
(define listener
|
||||
(transition/no-state
|
||||
(endpoint #:subscriber (tcp-channel ? (tcp-listener 2322) ?)
|
||||
#:observer
|
||||
#:conversation r
|
||||
#:on-presence (session-vm r))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (check-remote-identification! peer-identification-string)
|
||||
(define required-peer-identification-regex #rx"^SSH-2\\.0-.*")
|
||||
;; 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))
|
||||
(error 'ssh-session
|
||||
"Invalid peer identification string ~v"
|
||||
peer-identification-string)))
|
||||
|
||||
(define (spy marker)
|
||||
(define (dump what message)
|
||||
(write `(,marker ,what ,message))
|
||||
(newline)
|
||||
(flush-output)
|
||||
(void))
|
||||
(list
|
||||
(endpoint #:subscriber (wild) #:everything
|
||||
#:role r
|
||||
#:on-presence (dump 'arrived r)
|
||||
#:on-absence (dump 'departed r)
|
||||
[message (dump 'message message)])
|
||||
(endpoint #:publisher (wild) #:everything
|
||||
#:role r
|
||||
#:on-presence (dump 'arrived r)
|
||||
#:on-absence (dump 'departed r)
|
||||
[message (dump 'message message)])))
|
||||
|
||||
(define-syntax-rule (wait-as my-orientation topic action ...)
|
||||
(endpoint my-orientation topic #:observer
|
||||
#:let-name endpoint-name
|
||||
#:state state
|
||||
#:on-presence (begin (printf "WAIT ENDED: ~v\n" topic)
|
||||
(sequence-actions (transition state
|
||||
(delete-endpoint endpoint-name)
|
||||
action ...)))))
|
||||
|
||||
(define (session-vm new-conversation)
|
||||
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
||||
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
||||
|
||||
(define (issue-identification-string)
|
||||
(at-meta-level
|
||||
(send-message (tcp-channel local-addr remote-addr
|
||||
(bytes-append local-identification #"\r\n")))))
|
||||
|
||||
(define (read-handshake-and-become-reader)
|
||||
(transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't!
|
||||
(at-meta-level
|
||||
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?)
|
||||
#:name 'socket-reader
|
||||
#:state state
|
||||
[(tcp-channel _ _ (? eof-object?))
|
||||
(transition state (quit))]
|
||||
[(tcp-channel _ _ (? bytes? remote-identification))
|
||||
(begin
|
||||
(check-remote-identification! remote-identification)
|
||||
(sequence-actions (transition state)
|
||||
;; First, set the incoming mode to bytes.
|
||||
(at-meta-level
|
||||
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes))))
|
||||
;; Then initialise the reader, switching to packet-reading mode.
|
||||
(lambda (ignored-state) (ssh-reader new-conversation))
|
||||
;; Finally, spawn the remaining processes and issue the initial credit to the reader.
|
||||
(spawn #:debug-name 'ssh-writer
|
||||
#:child (ssh-writer new-conversation)
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
)
|
||||
;; Wait for the reader and writer get started, then tell
|
||||
;; the reader we are ready for a single packet and spawn
|
||||
;; the session manager.
|
||||
(printf "BOO\n")
|
||||
(wait-as #:subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||
(printf "YAY\n") (flush-output)
|
||||
(wait-as #:publisher (outbound-packet (wild))
|
||||
(printf "ALSO YAY\n") (flush-output)
|
||||
(send-message (inbound-credit 1))
|
||||
(spawn #:debug-name 'ssh-session
|
||||
#:pid session-pid
|
||||
#:child (ssh-session session-pid
|
||||
local-identification
|
||||
remote-identification
|
||||
repl-boot
|
||||
'server)
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
)))))]))))
|
||||
|
||||
(define (exn->outbound-packet reason)
|
||||
(outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason)
|
||||
(string->bytes/utf-8 (exn-message reason))
|
||||
#"")))
|
||||
|
||||
(define (disconnect-message-required? reason)
|
||||
(and (exn:fail:contract:protocol? reason)
|
||||
(not (exn:fail:contract:protocol-originated-at-peer? reason))))
|
||||
|
||||
(define (active-exception-handler reason)
|
||||
;; This is kind of gross: because the absence handler gets invoked
|
||||
;; several times in a row because of multiple flows intersecting
|
||||
;; this role, we have to be careful to make the transmission of
|
||||
;; the disconnection packet idempotent.
|
||||
;; TODO: this is likely no longer true now we're using exit-signals %%%
|
||||
(define interesting? (disconnect-message-required? reason))
|
||||
(transition inert-exception-handler
|
||||
(when interesting? (send-message (exn->outbound-packet reason)))
|
||||
(yield #:state state ;; gross
|
||||
(transition state (at-meta-level (quit #:reason (and interesting? reason)))))))
|
||||
|
||||
(define (inert-exception-handler reason)
|
||||
inert-exception-handler)
|
||||
|
||||
(nested-vm #:debug-name (list 'ssh-session-vm new-conversation)
|
||||
(event-relay 'ssh-event-relay)
|
||||
(timer-relay 'ssh-timer-relay)
|
||||
(spy 'SSH)
|
||||
|
||||
(issue-identification-string)
|
||||
|
||||
;; Expect identification string, then update (!) our inbound
|
||||
;; subscription handler to switch to packet mode.
|
||||
(at-meta-level
|
||||
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'lines)))
|
||||
(send-feedback (tcp-channel remote-addr local-addr (tcp-credit 1))))
|
||||
|
||||
(spawn #:debug-name 'ssh-reader
|
||||
#:child (read-handshake-and-become-reader)
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
)
|
||||
|
||||
;; TODO: canary:
|
||||
;; (spawn #:child
|
||||
;; (transition active-exception-handler
|
||||
;; (role (topic-subscriber (exit-signal (wild) (wild)))
|
||||
;; #:state current-handler
|
||||
;; #:reason reason
|
||||
;; #:on-absence (current-handler reason))))
|
||||
))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (repl-boot user-name)
|
||||
(list
|
||||
(event-relay 'app-event-relay)
|
||||
(spy 'APP)
|
||||
(at-meta-level
|
||||
(endpoint #:subscriber (channel-message (channel-stream-name #t (wild)) (wild))
|
||||
#:conversation (channel-message (channel-stream-name _ cname) _)
|
||||
#:on-presence (spawn #:debug-name cname #:child (repl-instance user-name cname))))))
|
||||
|
||||
;; (repl-instance InputPort OutputPort InputPort OutputPort)
|
||||
(struct repl-instance-state (c2s-in ;; used by thread to read input from relay
|
||||
c2s-out ;; used by relay to feed input from remote to the thread
|
||||
s2c-in ;; used by relay to feed output from thread to remote
|
||||
s2c-out ;; used by thread to write output to relay
|
||||
) #:prefab)
|
||||
|
||||
(define (repl-instance user-name cname)
|
||||
(define inbound-stream (channel-stream-name #t cname))
|
||||
(define outbound-stream (channel-stream-name #f cname))
|
||||
(define (ch-do action-ctor stream body)
|
||||
(at-meta-level (action-ctor (channel-message stream body))))
|
||||
(define (handle-channel-message state body)
|
||||
(match body
|
||||
[(channel-stream-request #"pty-req" _)
|
||||
(match-define (repl-instance-state old-in _ _ old-out) state)
|
||||
(define-values (cooked-in cooked-out) (cook-io old-in old-out "> "))
|
||||
(transition (struct-copy repl-instance-state state
|
||||
[c2s-in cooked-in]
|
||||
[s2c-out cooked-out])
|
||||
(ch-do send-feedback inbound-stream (channel-stream-ok)))]
|
||||
[(channel-stream-notify #"env" _)
|
||||
;; Don't care
|
||||
(transition state)]
|
||||
[(channel-stream-request #"shell" _)
|
||||
(match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state)
|
||||
(define buffer-size 1024)
|
||||
(define dummy-buffer (make-bytes buffer-size))
|
||||
(define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out))))
|
||||
(transition state
|
||||
(ch-do send-feedback inbound-stream (channel-stream-ok))
|
||||
(endpoint #:subscriber (cons (thread-dead-evt repl-thread) (wild))
|
||||
[_ (quit #:reason "REPL thread exited")])
|
||||
(endpoint #:subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild))
|
||||
;; We're using peek-bytes-avail!-evt rather than
|
||||
;; read-bytes-avail!-evt because of potential overwriting
|
||||
;; of the buffer. The overwriting can happen when there's
|
||||
;; any latency between handling the event and the next
|
||||
;; firing of the event, since the peek-bytes-avail!-evt
|
||||
;; will overwrite its buffer next time it's synced on.
|
||||
#:state state
|
||||
[(cons _ (? eof-object?))
|
||||
(let ()
|
||||
(match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
|
||||
(close-input-port c2s-in)
|
||||
(close-output-port c2s-out)
|
||||
(close-input-port s2c-in)
|
||||
(close-output-port s2c-out)
|
||||
(transition state (quit)))]
|
||||
[(cons _ (? number? count))
|
||||
(transition state
|
||||
(ch-do send-message outbound-stream (channel-stream-data
|
||||
(read-bytes count s2c-in))))]))]
|
||||
[(or (channel-stream-data #"\4") ;; C-d a.k.a EOT
|
||||
(channel-stream-eof))
|
||||
(let ()
|
||||
(close-output-port (repl-instance-state-c2s-out state))
|
||||
;; ^ this signals the repl thread to exit.
|
||||
;; Now, wait for it to do so.
|
||||
(transition state))]
|
||||
[(channel-stream-data bs)
|
||||
(write-bytes bs (repl-instance-state-c2s-out state))
|
||||
(flush-output (repl-instance-state-c2s-out state))
|
||||
(transition state
|
||||
(ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))]
|
||||
[m
|
||||
(write `(channel inbound ,m)) (newline)
|
||||
(transition state)]))
|
||||
(match (channel-name-type cname)
|
||||
[#"session"
|
||||
(define-values (c2s-in c2s-out) (make-pipe))
|
||||
(define-values (s2c-in s2c-out) (make-pipe))
|
||||
(transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
|
||||
(at-meta-level
|
||||
(endpoint #:subscriber (channel-message inbound-stream (wild))
|
||||
#:state state
|
||||
#:on-presence (transition state
|
||||
(ch-do send-feedback inbound-stream (channel-stream-config
|
||||
(default-packet-limit)
|
||||
#""))
|
||||
(ch-do send-feedback inbound-stream (channel-stream-credit 1024)))
|
||||
[(channel-message _ body)
|
||||
(handle-channel-message state body)]))
|
||||
(at-meta-level
|
||||
(endpoint #:publisher (channel-message outbound-stream (wild))
|
||||
[m
|
||||
(begin
|
||||
(write `(channel outbound ,cname ,m)) (newline)
|
||||
(void))])))]
|
||||
[type
|
||||
(transition/no-state
|
||||
(at-meta-level (send-message
|
||||
(channel-message outbound-stream
|
||||
(channel-stream-open-failure
|
||||
SSH_OPEN_UNKNOWN_CHANNEL_TYPE
|
||||
(bytes-append #"Unknown channel type " type))))))]))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; TODO: module+
|
||||
(main)
|
|
@ -0,0 +1,7 @@
|
|||
-----BEGIN DH PARAMETERS-----
|
||||
MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO
|
||||
NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr
|
||||
+1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc
|
||||
YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei
|
||||
j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==
|
||||
-----END DH PARAMETERS-----
|
|
@ -0,0 +1,5 @@
|
|||
-----BEGIN DH PARAMETERS-----
|
||||
MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE
|
||||
3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta
|
||||
iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC
|
||||
-----END DH PARAMETERS-----
|
|
@ -0,0 +1,28 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Construct Oakley MODP Diffie-Hellman groups from RFCs 2409 and 3526.
|
||||
|
||||
(provide dh:oakley-group-2
|
||||
dh:oakley-group-14)
|
||||
|
||||
;;(require (planet vyzo/crypto))
|
||||
(require (planet vyzo/crypto/dh))
|
||||
(require (only-in net/base64 base64-decode))
|
||||
|
||||
(define dh:oakley-group-2
|
||||
(make-!dh
|
||||
1024
|
||||
(base64-decode
|
||||
#"MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE
|
||||
3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta
|
||||
iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC")))
|
||||
|
||||
(define dh:oakley-group-14
|
||||
(make-!dh
|
||||
2048
|
||||
(base64-decode
|
||||
#"MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO
|
||||
NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr
|
||||
+1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc
|
||||
YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei
|
||||
j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==")))
|
|
@ -0,0 +1,43 @@
|
|||
#lang racket/base
|
||||
;; Sandbox management and use.
|
||||
|
||||
(require racket/match)
|
||||
(require racket/sandbox)
|
||||
|
||||
(provide repl-shell)
|
||||
|
||||
(struct user-state (name master-sandbox master-namespace) #:transparent)
|
||||
|
||||
(define *user-states* (make-hash))
|
||||
|
||||
(define (get-user-state username)
|
||||
(when (not (hash-has-key? *user-states* username))
|
||||
(let* ((sb (make-evaluator 'racket/base))
|
||||
(ns (call-in-sandbox-context sb current-namespace)))
|
||||
(hash-set! *user-states* username
|
||||
(user-state username
|
||||
sb
|
||||
ns))))
|
||||
(hash-ref *user-states* username))
|
||||
|
||||
(define (repl-shell username in out)
|
||||
(match-define (user-state _ master-sandbox master-namespace) (get-user-state username))
|
||||
(parameterize ((current-input-port in)
|
||||
(current-output-port out)
|
||||
(current-error-port out)
|
||||
(sandbox-input in)
|
||||
(sandbox-output out)
|
||||
(sandbox-error-output out)
|
||||
(sandbox-memory-limit 2) ;; megabytes
|
||||
(sandbox-eval-limits #f)
|
||||
(sandbox-namespace-specs (list (lambda () master-namespace))))
|
||||
(printf "Hello, ~a.\n" username)
|
||||
(define slave-sandbox (make-evaluator '(begin)))
|
||||
;; ^^ uses master-namespace via sandbox-namespace-specs
|
||||
(parameterize ((current-namespace master-namespace)
|
||||
(current-eval slave-sandbox))
|
||||
(read-eval-print-loop))
|
||||
(fprintf out "\nGoodbye!\n")
|
||||
(kill-evaluator slave-sandbox)
|
||||
(close-input-port in)
|
||||
(close-output-port out)))
|
|
@ -0,0 +1,115 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
||||
(provide (struct-out ssh-channel)
|
||||
|
||||
(struct-out channel-name)
|
||||
(struct-out channel-stream-name)
|
||||
(struct-out channel-message)
|
||||
|
||||
(struct-out channel-stream-credit)
|
||||
(struct-out channel-stream-data)
|
||||
(struct-out channel-stream-extended-data)
|
||||
(struct-out channel-stream-eof)
|
||||
(struct-out channel-stream-notify)
|
||||
(struct-out channel-stream-request)
|
||||
(struct-out channel-stream-ok)
|
||||
(struct-out channel-stream-fail)
|
||||
(struct-out channel-stream-config)
|
||||
(struct-out channel-stream-open-failure))
|
||||
|
||||
;; A CloseState is one of
|
||||
;; - 'neither, indicating that neither side has signalled closure
|
||||
;; - 'local, only the local end has signalled closure
|
||||
;; - 'remote, only the remote end has signalled closure
|
||||
;; - 'both, both ends have signalled closure.
|
||||
;; Represents local knowledge of the state of a shared shutdown state
|
||||
;; machine.
|
||||
;;
|
||||
;; 'neither
|
||||
;; / \
|
||||
;; \/ \/
|
||||
;; 'local 'remote
|
||||
;; \ /
|
||||
;; \/ \/
|
||||
;; 'both
|
||||
|
||||
;; TODO: Once the presence-based routing table can be queried, the
|
||||
;; CloseState becomes redundant, because we can just ask which roles
|
||||
;; remain to decide whether either direction is still open.
|
||||
|
||||
;; A ChannelState is a (ssh-channel ...) TODO
|
||||
;; Named ssh-channel to avoid conflicts with Racket's built-in
|
||||
;; synchronous channels.
|
||||
(struct ssh-channel (name ;; ChannelName
|
||||
local-ref ;; Uint32
|
||||
remote-ref ;; Maybe<Uint32>
|
||||
outbound-packet-size ;; Maybe<Natural>
|
||||
close-state ;; CloseState covering CLOSE signals
|
||||
)
|
||||
#:transparent)
|
||||
|
||||
;; ChannelName = (channel-name Boolean Bytes Any)
|
||||
;; Names a channel within a connection. Unique within a particular
|
||||
;; connection. If (locally-originated?) is true, then the local peer
|
||||
;; is the one that opened this channel, and the local peer is
|
||||
;; reponsible for choosing the (identifier) and ensuring that it is
|
||||
;; unique with respect to other locally-originated streams within this
|
||||
;; connection; if false, the remote peer opened the channel, and the
|
||||
;; (identifier) is chosen managed by the connection-control code. If
|
||||
;; (locally-originated?) is true, the (type) is chosen by the local
|
||||
;; peer, otherwise it is chosen by the remote peer.
|
||||
(struct channel-name (locally-originated? type identifier) #:prefab)
|
||||
|
||||
;; ChannelStreamName = (channel-stream-name Boolean ChannelName)
|
||||
;; Names a stream within a channel within a connection. If (inbound?)
|
||||
;; is true, this is the stream of packets from the remote peer to the
|
||||
;; local peer; if false, the reverse.
|
||||
(struct channel-stream-name (inbound? channel) #:prefab)
|
||||
|
||||
;; ChannelMessage = (channel-message ChannelStreamName ChannelMessageBody)
|
||||
;; Relates a message to a particular stream within a channel within a
|
||||
;; connection.
|
||||
(struct channel-message (stream-name body) #:prefab)
|
||||
|
||||
;; A ChannelMessageBody is one of
|
||||
;; -- (channel-stream-credit NonNegativeInteger) **
|
||||
;; Informs the publisher that it may transmit another (count)
|
||||
;; bytes.
|
||||
;; -- (channel-stream-data Bytes)
|
||||
;; Data intended for the subscriber.
|
||||
;; -- (channel-stream-extended-data Uint32 Bytes)
|
||||
;; Extended data intended for the subscriber. The type code is one
|
||||
;; of those defined in ssh-numbers.rkt; for example,
|
||||
;; SSH_EXTENDED_DATA_STDERR.
|
||||
;; -- (channel-stream-eof)
|
||||
;; Signals the end of the data stream. Notice that channel closure
|
||||
;; is signalled with presence changes.
|
||||
;; -- (channel-stream-notify Bytes Bytes)
|
||||
;; One-way notification of SSH_MSG_CHANNEL_REQUEST.
|
||||
;; -- (channel-stream-request Bytes Bytes)
|
||||
;; RPC SSH_MSG_CHANNEL_REQUEST request.
|
||||
;; -- (channel-stream-ok) **
|
||||
;; RPC SSH_MSG_CHANNEL_REQUEST reply.
|
||||
;; -- (channel-stream-fail) **
|
||||
;; RPC SSH_MSG_CHANNEL_REQUEST error.
|
||||
;; -- (channel-stream-config Uint32 Bytes) **
|
||||
;; Either SSH_MSG_CHANNEL_OPEN or
|
||||
;; SSH_MSG_CHANNEL_OPEN_CONFIRMATION, depending on direction of
|
||||
;; travel. Must be sent before any channel-stream-credit messages.
|
||||
;; -- (channel-stream-open-failure Uint32 Bytes)
|
||||
;; SSH_MSG_CHANNEL_OPEN_FAILURE.
|
||||
;;
|
||||
;; Messages marked ** travel "upstream", from subscriber to publisher.
|
||||
(struct channel-stream-credit (count) #:prefab)
|
||||
(struct channel-stream-data (bytes) #:prefab)
|
||||
(struct channel-stream-extended-data (type bytes) #:prefab)
|
||||
(struct channel-stream-eof () #:prefab)
|
||||
(struct channel-stream-notify (type bytes) #:prefab)
|
||||
(struct channel-stream-request (type bytes) #:prefab)
|
||||
(struct channel-stream-ok () #:prefab)
|
||||
(struct channel-stream-fail () #:prefab)
|
||||
(struct channel-stream-config (maximum-packet-size extra-data) #:prefab)
|
||||
(struct channel-stream-open-failure (reason description) #:prefab)
|
|
@ -0,0 +1,41 @@
|
|||
#lang racket/base
|
||||
;; Exceptions and error-raising and -handling utilities used in structuring SSH sessions.
|
||||
|
||||
(provide (struct-out exn:fail:contract:protocol)
|
||||
disconnect-with-error
|
||||
disconnect-with-error/local-info
|
||||
disconnect-with-error*)
|
||||
|
||||
;; 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
|
||||
;; the exn-message as the description. The local-info field is useful
|
||||
;; information for diagnosing problems known to the local stack that
|
||||
;; should not be transmitted to the remote party. For example, upon
|
||||
;; detection of a MAC failure, it might be useful to know the expected
|
||||
;; and actual MACs for debugging, but they should not be sent over the
|
||||
;; wire because we could be experiencing some kind of attack.
|
||||
(struct exn:fail:contract:protocol exn:fail:contract
|
||||
(reason-code local-info originated-at-peer?)
|
||||
#:transparent)
|
||||
|
||||
;; Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
|
||||
(define (disconnect-with-error reason-code format-string . args)
|
||||
(apply disconnect-with-error* #f '() reason-code format-string args))
|
||||
|
||||
;; Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
|
||||
(define (disconnect-with-error/local-info local-info reason-code format-string . args)
|
||||
(apply disconnect-with-error* #f local-info reason-code format-string args))
|
||||
|
||||
;; Boolean Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
|
||||
(define (disconnect-with-error* originated-at-peer?
|
||||
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
|
||||
originated-at-peer?))))
|
|
@ -0,0 +1,211 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match)
|
||||
(require racket/port)
|
||||
(require net/base64)
|
||||
|
||||
(require (planet vyzo/crypto))
|
||||
(require (planet tonyg/bitsyntax))
|
||||
(require "asn1-ber.rkt")
|
||||
(require "ssh-message-types.rkt")
|
||||
|
||||
(require rackunit)
|
||||
|
||||
(provide (struct-out rsa-private-key)
|
||||
(struct-out dsa-private-key)
|
||||
(struct-out rsa-public-key)
|
||||
(struct-out dsa-public-key)
|
||||
|
||||
public-key->pieces
|
||||
pieces->public-key
|
||||
|
||||
host-key-algorithm->keys
|
||||
host-key-algorithm->digest-type
|
||||
host-key-signature
|
||||
verify-host-key-signature!
|
||||
|
||||
pieces->ssh-host-key
|
||||
ssh-host-key->pieces)
|
||||
|
||||
(struct rsa-private-key (version n e d p q dmp1 dmq1 iqmp) #:transparent)
|
||||
(struct dsa-private-key (version p q g y x) #:transparent)
|
||||
(struct rsa-public-key (n e) #:transparent)
|
||||
(struct dsa-public-key (y p q g) #:transparent)
|
||||
|
||||
;; ASN.1 BER integers are signed.
|
||||
(define (bs->n bs) (bit-string->integer bs #t #t))
|
||||
(define (n->bs n) (integer->bit-string n (* 8 (mpint-width n)) #t))
|
||||
|
||||
(define (private-key->pieces key)
|
||||
(bytes->private-key-pieces (private-key->bytes key)))
|
||||
|
||||
(define (bytes->private-key-pieces bs)
|
||||
(match (asn1-ber-decode-all bs)
|
||||
(`(0 16 ((0 2 ,version-bytes)
|
||||
(0 2 ,n-bytes)
|
||||
(0 2 ,e-bytes)
|
||||
(0 2 ,d-bytes)
|
||||
(0 2 ,p-bytes)
|
||||
(0 2 ,q-bytes)
|
||||
(0 2 ,dmp1-bytes)
|
||||
(0 2 ,dmq1-bytes)
|
||||
(0 2 ,iqmp-bytes)))
|
||||
(rsa-private-key (bs->n version-bytes)
|
||||
(bs->n n-bytes)
|
||||
(bs->n e-bytes)
|
||||
(bs->n d-bytes)
|
||||
(bs->n p-bytes)
|
||||
(bs->n q-bytes)
|
||||
(bs->n dmp1-bytes)
|
||||
(bs->n dmq1-bytes)
|
||||
(bs->n iqmp-bytes)))
|
||||
(`(0 16 ((0 2 ,version-bytes)
|
||||
(0 2 ,p-bytes)
|
||||
(0 2 ,q-bytes)
|
||||
(0 2 ,g-bytes)
|
||||
(0 2 ,public-key-bytes) ;; y
|
||||
(0 2 ,private-key-bytes))) ;; x
|
||||
(dsa-private-key (bs->n version-bytes)
|
||||
(bs->n p-bytes)
|
||||
(bs->n q-bytes)
|
||||
(bs->n g-bytes)
|
||||
(bs->n public-key-bytes)
|
||||
(bs->n private-key-bytes)))))
|
||||
|
||||
(define (pieces->private-key p)
|
||||
(match p
|
||||
((struct rsa-private-key (version n e d p q dmp1 dmq1 iqmp))
|
||||
(bytes->private-key pkey:rsa
|
||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs version))
|
||||
(0 2 ,(n->bs n))
|
||||
(0 2 ,(n->bs e))
|
||||
(0 2 ,(n->bs d))
|
||||
(0 2 ,(n->bs p))
|
||||
(0 2 ,(n->bs q))
|
||||
(0 2 ,(n->bs dmp1))
|
||||
(0 2 ,(n->bs dmq1))
|
||||
(0 2 ,(n->bs iqmp)))))))
|
||||
((struct dsa-private-key (version p q g y x))
|
||||
(bytes->private-key pkey:dsa
|
||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs version))
|
||||
(0 2 ,(n->bs p))
|
||||
(0 2 ,(n->bs q))
|
||||
(0 2 ,(n->bs g))
|
||||
(0 2 ,(n->bs y))
|
||||
(0 2 ,(n->bs x)))))))))
|
||||
|
||||
(define (public-key->pieces key)
|
||||
(match (asn1-ber-decode-all (public-key->bytes key))
|
||||
(`(0 16 ((0 2 ,n-bytes)
|
||||
(0 2 ,e-bytes)))
|
||||
(rsa-public-key (bs->n n-bytes)
|
||||
(bs->n e-bytes)))
|
||||
(`(0 16 ((0 2 ,public-key-bytes) ;; y
|
||||
(0 2 ,p-bytes)
|
||||
(0 2 ,q-bytes)
|
||||
(0 2 ,g-bytes)))
|
||||
(dsa-public-key (bs->n public-key-bytes)
|
||||
(bs->n p-bytes)
|
||||
(bs->n q-bytes)
|
||||
(bs->n g-bytes)))))
|
||||
|
||||
(define (pieces->public-key p)
|
||||
(match p
|
||||
((struct rsa-public-key (n e))
|
||||
(bytes->public-key pkey:rsa
|
||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs n))
|
||||
(0 2 ,(n->bs e)))))))
|
||||
((struct dsa-public-key (y p q g))
|
||||
(bytes->public-key pkey:dsa
|
||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs y))
|
||||
(0 2 ,(n->bs p))
|
||||
(0 2 ,(n->bs q))
|
||||
(0 2 ,(n->bs g)))))))))
|
||||
|
||||
(define (host-key-algorithm->keys host-key-alg)
|
||||
(case host-key-alg
|
||||
((ssh-dss) (values host-key-dsa-private host-key-dsa-public))
|
||||
(else (error 'host-key-algorithm->keys "Unsupported host-key-alg ~v" host-key-alg))))
|
||||
|
||||
(define (host-key-algorithm->digest-type host-key-alg)
|
||||
(case host-key-alg
|
||||
((ssh-rsa) digest:sha1)
|
||||
((ssh-dss) digest:dss1)
|
||||
(else (error 'host-key-algorithm->digest-type "Unsupported host-key-alg ~v" host-key-alg))))
|
||||
|
||||
(define (host-key-signature private-key host-key-alg exchange-hash)
|
||||
(case host-key-alg
|
||||
((ssh-rsa)
|
||||
;; TODO: offer ssh-rsa. See comment in definition of
|
||||
;; local-algorithm-list in ssh-transport.rkt.
|
||||
(error 'host-key-signature "ssh-rsa host key signatures unimplemented"))
|
||||
((ssh-dss)
|
||||
(match (asn1-ber-decode-all (sign private-key digest:dss1 exchange-hash))
|
||||
(`(0 16 ((0 2 ,r-bytes)
|
||||
(0 2 ,s-bytes)))
|
||||
(bit-string (#"ssh-dss" :: (t:string))
|
||||
((bit-string ((bs->n r-bytes) :: big-endian integer bits 160)
|
||||
((bs->n s-bytes) :: big-endian integer bits 160))
|
||||
:: (t:string))))))))
|
||||
|
||||
(define (verify-host-key-signature! public-key host-key-alg exchange-hash h-signature)
|
||||
;; TODO: If we are *re*keying, worth checking here that the key hasn't *changed* either.
|
||||
(write `(TODO check-host-key!)) (newline) (flush-output) ;; actually check the identity TOFU/POP
|
||||
(case host-key-alg
|
||||
((ssh-rsa)
|
||||
;; TODO: offer ssh-rsa. See comment in definition of
|
||||
;; local-algorithm-list in ssh-transport.rkt.
|
||||
(error 'verify-host-key-signature! "ssh-rsa host key signatures unimplemented"))
|
||||
((ssh-dss)
|
||||
(define signature (bit-string-case h-signature
|
||||
([ (= #"ssh-dss" :: (t:string #:pack))
|
||||
(r-and-s :: (t:string)) ]
|
||||
(bit-string-case r-and-s
|
||||
([ (r :: big-endian integer bits 160)
|
||||
(s :: big-endian integer bits 160) ]
|
||||
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs r))
|
||||
(0 2 ,(n->bs s))))))))))
|
||||
(when (not (verify public-key digest:dss1 signature exchange-hash))
|
||||
(error 'verify-host-key-signature! "Signature mismatch")))))
|
||||
|
||||
(define (pieces->ssh-host-key pieces)
|
||||
(match pieces
|
||||
((struct rsa-public-key (n e))
|
||||
(bit-string (#"ssh-rsa" :: (t:string))
|
||||
(e :: (t:mpint))
|
||||
(n :: (t:mpint))))
|
||||
((struct dsa-public-key (y p q g))
|
||||
(bit-string (#"ssh-dss" :: (t:string))
|
||||
(p :: (t:mpint))
|
||||
(q :: (t:mpint))
|
||||
(g :: (t:mpint))
|
||||
(y :: (t:mpint))))))
|
||||
|
||||
(define (ssh-host-key->pieces blob)
|
||||
(bit-string-case blob
|
||||
([ (= #"ssh-rsa" :: (t:string #:pack))
|
||||
(e :: (t:mpint))
|
||||
(n :: (t:mpint)) ]
|
||||
(rsa-public-key n e))
|
||||
([ (= #"ssh-dss" :: (t:string #:pack))
|
||||
(p :: (t:mpint))
|
||||
(q :: (t:mpint))
|
||||
(g :: (t:mpint))
|
||||
(y :: (t:mpint)) ]
|
||||
(dsa-public-key y p q g))))
|
||||
|
||||
;; TODO: proper store for keys
|
||||
|
||||
(define (load-private-key filename)
|
||||
(pieces->private-key
|
||||
(bytes->private-key-pieces
|
||||
(base64-decode
|
||||
(regexp-replace* #rx"(?m:^-.*-$)"
|
||||
(call-with-input-file filename port->bytes)
|
||||
#"")))))
|
||||
|
||||
(define host-key-dsa-private (load-private-key "test-dsa-key"))
|
||||
(define host-key-dsa-public (pkey->public-key host-key-dsa-private))
|
||||
|
||||
(check-equal? (public-key->bytes (pieces->public-key (public-key->pieces host-key-dsa-public)))
|
||||
(public-key->bytes host-key-dsa-private))
|
|
@ -0,0 +1,345 @@
|
|||
#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)
|
||||
|
||||
(provide t:boolean
|
||||
t:string
|
||||
t:mpint
|
||||
mpint-width
|
||||
t:name-list)
|
||||
|
||||
(provide (struct-out ssh-msg-kexinit)
|
||||
(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)
|
||||
(struct-out ssh-msg-debug)
|
||||
(struct-out ssh-msg-ignore)
|
||||
(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)
|
||||
)
|
||||
|
||||
(define encoder-map (make-hasheqv))
|
||||
(define decoder-map (make-hasheqv))
|
||||
|
||||
(define (ssh-message-decode packet)
|
||||
(define type-code (bytes-ref packet 0))
|
||||
(define decoder (hash-ref decoder-map type-code #f))
|
||||
(if decoder
|
||||
(decoder packet)
|
||||
#f))
|
||||
|
||||
(define (ssh-message-encode m)
|
||||
(bit-string->bytes ((hash-ref encoder-map (prefab-struct-key m)) m)))
|
||||
|
||||
(define-syntax define-ssh-message-type
|
||||
(syntax-rules ()
|
||||
((_ name type-byte-value (field-type field-name) ...)
|
||||
(begin
|
||||
(struct name (field-name ...) #:prefab)
|
||||
(hash-set! encoder-map 'name
|
||||
(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 t:boolean
|
||||
(syntax-rules ()
|
||||
((_ #t input ks kf)
|
||||
(bit-string-case input
|
||||
([ v (rest :: binary) ]
|
||||
(ks (not (zero? v)) rest))
|
||||
(else (kf))))
|
||||
((_ #f v) (bit-string (if v 1 0)))))
|
||||
|
||||
(define-syntax t:packed-bytes
|
||||
(syntax-rules ()
|
||||
((_ #t input ks kf n)
|
||||
(bit-string-case input
|
||||
([ (bs :: binary bytes n) (rest :: binary) ]
|
||||
(ks (bit-string->bytes bs) rest))
|
||||
(else (kf))))
|
||||
((_ #t input ks kf)
|
||||
(bit-string-case input
|
||||
([ (rest :: binary) ]
|
||||
(ks (bit-string->bytes rest) #""))
|
||||
(else (kf))))
|
||||
((_ #f bs n) (bit-string (bs :: binary)))
|
||||
((_ #f bs) (bit-string (bs :: binary)))))
|
||||
|
||||
(define-syntax t:string
|
||||
(syntax-rules ()
|
||||
((_ #t input ks kf #:pack)
|
||||
(t:string #t input (lambda (v rest) (ks (bit-string->bytes v) rest)) kf))
|
||||
((_ #t input ks kf)
|
||||
(bit-string-case input
|
||||
([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
|
||||
(ks body rest))
|
||||
(else (kf))))
|
||||
((_ #f bs #:pack) (t:string #f bs)) ;; #:pack ignored on encoding
|
||||
((_ #f bs)
|
||||
(bit-string ((bytes-length (bit-string->bytes bs)) :: integer bits 32)
|
||||
(bs :: binary)))))
|
||||
|
||||
(define-syntax t:mpint
|
||||
(syntax-rules ()
|
||||
((_ #t 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 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 input ks kf)
|
||||
(t:string #t
|
||||
input
|
||||
(lambda (body rest) (ks (name-list->symbols body) rest))
|
||||
kf))
|
||||
((_ #f 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))
|
||||
((byte n) #'((t:packed-bytes n)))
|
||||
(boolean #'((t:boolean)))
|
||||
(uint32 #'(integer bits 32))
|
||||
(uint64 #'(integer bits 64))
|
||||
(string #'((t:string #:pack)))
|
||||
(mpint #'((t:mpint)))
|
||||
(name-list #'((t:name-list)))
|
||||
(extension #'((t:packed-bytes)))))
|
||||
|
||||
(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 ...))))
|
||||
(map (lambda (index type)
|
||||
#`((vector-ref vec #,index) :: #,@(codec-options 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)
|
||||
(syntax-case stx ()
|
||||
((_ struct-name type-byte-value field-type ...)
|
||||
(with-syntax (((temp-name ...) (generate-temporaries #'(field-type ...)))
|
||||
(((codec-option ...) ...)
|
||||
(map codec-options (syntax->list #'(field-type ...)))))
|
||||
#`(lambda (packet)
|
||||
(bit-string-case packet
|
||||
([ (= type-byte-value) (temp-name :: codec-option ...) ... ]
|
||||
(struct-name temp-name ...)))))))))
|
||||
|
||||
(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))))))
|
||||
|
||||
(struct test-message (value) #:prefab)
|
||||
(let ((test-decode (compute-ssh-message-decoder test-message 123 mpint))
|
||||
(test-encode (compute-ssh-message-encoder 123 mpint)))
|
||||
(define (bidi-check msg enc-without-type-tag)
|
||||
(let ((enc (bytes-append (bytes 123) enc-without-type-tag)))
|
||||
(let ((msg-enc (bit-string->bytes (test-encode msg)))
|
||||
(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))
|
||||
|
||||
(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))
|
||||
|
||||
(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)
|
||||
;; 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".
|
||||
(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)
|
||||
|
||||
(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))
|
||||
|
||||
(define-ssh-message-type ssh-msg-service-request SSH_MSG_SERVICE_REQUEST
|
||||
(string service-name))
|
||||
|
||||
(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))
|
|
@ -0,0 +1,378 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "mapping.rkt")
|
||||
|
||||
(provide (all-defined-out)) ;; I know, I know
|
||||
|
||||
;; Assigned numbers, from RFCs 4250 and 4344.
|
||||
|
||||
;; Protocol packets have message numbers in the range 1 to 255. These
|
||||
;; numbers are allocated as follows:
|
||||
;;
|
||||
;; Transport layer protocol:
|
||||
;;
|
||||
;; 1 to 19 Transport layer generic (e.g., disconnect, ignore,
|
||||
;; debug, etc.)
|
||||
;; 20 to 29 Algorithm negotiation
|
||||
;; 30 to 49 Key exchange method specific (numbers can be reused
|
||||
;; for different authentication methods)
|
||||
;;
|
||||
;; User authentication protocol:
|
||||
;;
|
||||
;; 50 to 59 User authentication generic
|
||||
;; 60 to 79 User authentication method specific (numbers can be
|
||||
;; reused for different authentication methods)
|
||||
;;
|
||||
;; Connection protocol:
|
||||
;;
|
||||
;; 80 to 89 Connection protocol generic
|
||||
;; 90 to 127 Channel related messages
|
||||
;;
|
||||
;; Reserved for client protocols:
|
||||
;;
|
||||
;; 128 to 191 Reserved
|
||||
;;
|
||||
;; Local extensions:
|
||||
;;
|
||||
;; 192 to 255 Local extensions
|
||||
|
||||
(define (ssh-msg-type-transport-layer? msg-type) (>= 49 msg-type 1))
|
||||
(define (ssh-msg-type-transport-layer-generic? msg-type) (>= 19 msg-type 1))
|
||||
(define (ssh-msg-type-transport-layer-algorithm-negotiation? msg-type) (>= 29 msg-type 20))
|
||||
(define (ssh-msg-type-transport-layer-key-exchange? msg-type) (>= 49 msg-type 30))
|
||||
|
||||
(define (ssh-msg-type-authentication? msg-type) (>= 79 msg-type 50))
|
||||
(define (ssh-msg-type-authentication-generic? msg-type) (>= 59 msg-type 50))
|
||||
(define (ssh-msg-type-authentication-specific? msg-type) (>= 79 msg-type 60))
|
||||
|
||||
(define (ssh-msg-type-connection? msg-type) (>= 127 msg-type 80))
|
||||
(define (ssh-msg-type-connection-generic? msg-type) (>= 89 msg-type 80))
|
||||
(define (ssh-msg-type-connection-channel? msg-type) (>= 127 msg-type 90))
|
||||
|
||||
(define (ssh-msg-type-client? msg-type) (>= 191 msg-type 128))
|
||||
(define (ssh-msg-type-local? msg-type) (>= 255 msg-type 192))
|
||||
|
||||
;;; SSH message type IDs.
|
||||
;;
|
||||
;; Message ID Value Reference
|
||||
;; ----------- ----- ---------
|
||||
(define SSH_MSG_DISCONNECT 1) ;[SSH-TRANS]
|
||||
(define SSH_MSG_IGNORE 2) ;[SSH-TRANS]
|
||||
(define SSH_MSG_UNIMPLEMENTED 3) ;[SSH-TRANS]
|
||||
(define SSH_MSG_DEBUG 4) ;[SSH-TRANS]
|
||||
(define SSH_MSG_SERVICE_REQUEST 5) ;[SSH-TRANS]
|
||||
(define SSH_MSG_SERVICE_ACCEPT 6) ;[SSH-TRANS]
|
||||
(define SSH_MSG_KEXINIT 20) ;[SSH-TRANS]
|
||||
(define SSH_MSG_NEWKEYS 21) ;[SSH-TRANS]
|
||||
(define SSH_MSG_KEXDH_INIT 30) ;RFC 4253 errata
|
||||
(define SSH_MSG_KEXDH_REPLY 31) ;RFC 4253 errata
|
||||
(define SSH_MSG_USERAUTH_REQUEST 50) ;[SSH-USERAUTH]
|
||||
(define SSH_MSG_USERAUTH_FAILURE 51) ;[SSH-USERAUTH]
|
||||
(define SSH_MSG_USERAUTH_SUCCESS 52) ;[SSH-USERAUTH]
|
||||
(define SSH_MSG_USERAUTH_BANNER 53) ;[SSH-USERAUTH]
|
||||
(define SSH_MSG_GLOBAL_REQUEST 80) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_REQUEST_SUCCESS 81) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_REQUEST_FAILURE 82) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_OPEN 90) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_OPEN_CONFIRMATION 91) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_OPEN_FAILURE 92) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_WINDOW_ADJUST 93) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_DATA 94) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_EXTENDED_DATA 95) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_EOF 96) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_CLOSE 97) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_REQUEST 98) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_SUCCESS 99) ;[SSH-CONNECT]
|
||||
(define SSH_MSG_CHANNEL_FAILURE 100) ;[SSH-CONNECT]
|
||||
|
||||
;; The following table identifies the initial assignments of the
|
||||
;; SSH_MSG_DISCONNECT 'description' and 'reason code' values.
|
||||
;;
|
||||
;; Symbolic Name reason code
|
||||
;; ------------- -----------
|
||||
(define SSH_DISCONNECT_HOST_NOT_ALLOWED_TO_CONNECT 1)
|
||||
(define SSH_DISCONNECT_PROTOCOL_ERROR 2)
|
||||
(define SSH_DISCONNECT_KEY_EXCHANGE_FAILED 3)
|
||||
(define SSH_DISCONNECT_RESERVED 4)
|
||||
(define SSH_DISCONNECT_MAC_ERROR 5)
|
||||
(define SSH_DISCONNECT_COMPRESSION_ERROR 6)
|
||||
(define SSH_DISCONNECT_SERVICE_NOT_AVAILABLE 7)
|
||||
(define SSH_DISCONNECT_PROTOCOL_VERSION_NOT_SUPPORTED 8)
|
||||
(define SSH_DISCONNECT_HOST_KEY_NOT_VERIFIABLE 9)
|
||||
(define SSH_DISCONNECT_CONNECTION_LOST 10)
|
||||
(define SSH_DISCONNECT_BY_APPLICATION 11)
|
||||
(define SSH_DISCONNECT_TOO_MANY_CONNECTIONS 12)
|
||||
(define SSH_DISCONNECT_AUTH_CANCELLED_BY_USER 13)
|
||||
(define SSH_DISCONNECT_NO_MORE_AUTH_METHODS_AVAILABLE 14)
|
||||
(define SSH_DISCONNECT_ILLEGAL_USER_NAME 15)
|
||||
|
||||
;; The initial assignments for the 'reason code' values and
|
||||
;; 'description' values are given in the table below. Note that the
|
||||
;; values for the 'reason code' are given in decimal format for
|
||||
;; readability, but they are actually uint32 values.
|
||||
;;
|
||||
;; Symbolic Name reason code
|
||||
;; ------------- -----------
|
||||
(define SSH_OPEN_ADMINISTRATIVELY_PROHIBITED 1)
|
||||
(define SSH_OPEN_CONNECT_FAILED 2)
|
||||
(define SSH_OPEN_UNKNOWN_CHANNEL_TYPE 3)
|
||||
(define SSH_OPEN_RESOURCE_SHORTAGE 4)
|
||||
|
||||
;; The initial assignments for the 'data_type_code' values and 'data'
|
||||
;; values are given in the table below. Note that the value for the
|
||||
;; 'data_type_code' is given in decimal format for readability, but the
|
||||
;; values are actually uint32 values.
|
||||
;;
|
||||
;; Symbolic name data_type_code
|
||||
;; ------------- --------------
|
||||
(define SSH_EXTENDED_DATA_STDERR 1)
|
||||
|
||||
;; The following table identifies the initial assignments of the opcode
|
||||
;; values that are used in the 'encoded terminal modes' value.
|
||||
|
||||
(define-mapping integer->terminal-mode-opcode terminal-mode-opcode->integer
|
||||
#:forward-default values
|
||||
#:backward-default values
|
||||
;; opcode mnemonic description
|
||||
;; ------ -------- -----------
|
||||
(0 TTY_OP_END);Indicates end of options.
|
||||
(1 VINTR) ;Interrupt character; 255 if none. Similarly
|
||||
; for the other characters. Not all of these
|
||||
; characters are supported on all systems.
|
||||
(2 VQUIT) ;The quit character (sends SIGQUIT signal on
|
||||
; POSIX systems).
|
||||
(3 VERASE) ;Erase the character to left of the cursor.
|
||||
(4 VKILL) ;Kill the current input line.
|
||||
(5 VEOF) ;End-of-file character (sends EOF from the
|
||||
; terminal).
|
||||
(6 VEOL) ;End-of-line character in addition to
|
||||
; carriage return and/or linefeed.
|
||||
(7 VEOL2) ;Additional end-of-line character.
|
||||
(8 VSTART) ;Continues paused output (normally
|
||||
; control-Q).
|
||||
(9 VSTOP) ;Pauses output (normally control-S).
|
||||
(10 VSUSP) ;Suspends the current program.
|
||||
(11 VDSUSP) ;Another suspend character.
|
||||
(12 VREPRINT) ;Reprints the current input line.
|
||||
(13 VWERASE) ;Erases a word left of cursor.
|
||||
(14 VLNEXT) ;Enter the next character typed literally,
|
||||
; even if it is a special character
|
||||
(15 VFLUSH) ;Character to flush output.
|
||||
(16 VSWTCH) ;Switch to a different shell layer.
|
||||
(17 VSTATUS) ;Prints system status line (load, command,
|
||||
; pid, etc).
|
||||
(18 VDISCARD) ;Toggles the flushing of terminal output.
|
||||
(30 IGNPAR) ;The ignore parity flag. The parameter
|
||||
; SHOULD be 0 if this flag is FALSE,
|
||||
; and 1 if it is TRUE.
|
||||
(31 PARMRK) ;Mark parity and framing errors.
|
||||
(32 INPCK) ;Enable checking of parity errors.
|
||||
(33 ISTRIP) ;Strip 8th bit off characters.
|
||||
(34 INLCR) ;Map NL into CR on input.
|
||||
(35 IGNCR) ;Ignore CR on input.
|
||||
(36 ICRNL) ;Map CR to NL on input.
|
||||
(37 IUCLC) ;Translate uppercase characters to
|
||||
; lowercase.
|
||||
(38 IXON) ;Enable output flow control.
|
||||
(39 IXANY) ;Any char will restart after stop.
|
||||
(40 IXOFF) ;Enable input flow control.
|
||||
(41 IMAXBEL) ;Ring bell on input queue full.
|
||||
(50 ISIG) ;Enable signals INTR, QUIT, [D]SUSP.
|
||||
(51 ICANON) ;Canonicalize input lines.
|
||||
(52 XCASE) ;Enable input and output of uppercase
|
||||
; characters by preceding their lowercase
|
||||
; equivalents with "\".
|
||||
(53 ECHO) ;Enable echoing.
|
||||
(54 ECHOE) ;Visually erase chars.
|
||||
(55 ECHOK) ;Kill character discards current line.
|
||||
(56 ECHONL) ;Echo NL even if ECHO is off.
|
||||
(57 NOFLSH) ;Don't flush after interrupt.
|
||||
(58 TOSTOP) ;Stop background jobs from output.
|
||||
(59 IEXTEN) ;Enable extensions.
|
||||
(60 ECHOCTL) ;Echo control characters as ^(Char).
|
||||
(61 ECHOKE) ;Visual erase for line kill.
|
||||
(62 PENDIN) ;Retype pending input.
|
||||
(70 OPOST) ;Enable output processing.
|
||||
(71 OLCUC) ;Convert lowercase to uppercase.
|
||||
(72 ONLCR) ;Map NL to CR-NL.
|
||||
(73 OCRNL) ;Translate carriage return to newline
|
||||
; (output).
|
||||
(74 ONOCR) ;Translate newline to carriage
|
||||
; return-newline (output).
|
||||
(75 ONLRET) ;Newline performs a carriage return
|
||||
; (output).
|
||||
(90 CS7) ;7 bit mode.
|
||||
(91 CS8) ;8 bit mode.
|
||||
(92 PARENB) ;Parity enable.
|
||||
(93 PARODD) ;Odd parity, else even.
|
||||
|
||||
(128 TTY_OP_ISPEED);Specifies the input baud rate in
|
||||
; bits per second.
|
||||
(129 TTY_OP_OSPEED);Specifies the output baud rate in
|
||||
; bits per second.
|
||||
)
|
||||
|
||||
;; The 'service name' is used to describe a protocol layer. The
|
||||
;; following table lists the initial assignments of the 'service name'
|
||||
;; values.
|
||||
(define ssh-service-names '(
|
||||
;; Service Name Reference
|
||||
;; ------------- ---------
|
||||
ssh-userauth ;[SSH-USERAUTH]
|
||||
ssh-connection ;[SSH-CONNECT]
|
||||
))
|
||||
|
||||
;; The Authentication Method Name is used to describe an authentication
|
||||
;; method for the "ssh-userauth" service [SSH-USERAUTH]. The following
|
||||
;; table identifies the initial assignments of the Authentication Method
|
||||
;; Names.
|
||||
(define ssh-authentication-method-names '(
|
||||
;; Method Name Reference
|
||||
;; ------------ ---------
|
||||
publickey ;[SSH-USERAUTH, Section 7]
|
||||
password ;[SSH-USERAUTH, Section 8]
|
||||
hostbased ;[SSH-USERAUTH, Section 9]
|
||||
none ;[SSH-USERAUTH, Section 5.2]
|
||||
))
|
||||
|
||||
;; The following table lists the initial assignments of the Connection
|
||||
;; Protocol Channel Types.
|
||||
(define ssh-channel-type-names '(
|
||||
;; Channel type Reference
|
||||
;; ------------ ---------
|
||||
session ;[SSH-CONNECT, Section 6.1]
|
||||
x11 ;[SSH-CONNECT, Section 6.3.2]
|
||||
forwarded-tcpip ;[SSH-CONNECT, Section 7.2]
|
||||
direct-tcpip ;[SSH-CONNECT, Section 7.2]
|
||||
))
|
||||
|
||||
;; The following table lists the initial assignments of the Connection
|
||||
;; Protocol Global Request Names.
|
||||
(define ssh-global-request-names '(
|
||||
;; Request type Reference
|
||||
;; ------------ ---------
|
||||
tcpip-forward ;[SSH-CONNECT, Section 7.1]
|
||||
cancel-tcpip-forward ;[SSH-CONNECT, Section 7.1]
|
||||
))
|
||||
|
||||
;; The following table lists the initial assignments of the Connection
|
||||
;; Protocol Channel Request Names.
|
||||
(define ssh-channel-request-names '(
|
||||
;; Request type Reference
|
||||
;; ------------ ---------
|
||||
pty-req ;[SSH-CONNECT, Section 6.2]
|
||||
x11-req ;[SSH-CONNECT, Section 6.3.1]
|
||||
env ;[SSH-CONNECT, Section 6.4]
|
||||
shell ;[SSH-CONNECT, Section 6.5]
|
||||
exec ;[SSH-CONNECT, Section 6.5]
|
||||
subsystem ;[SSH-CONNECT, Section 6.5]
|
||||
window-change ;[SSH-CONNECT, Section 6.7]
|
||||
xon-xoff ;[SSH-CONNECT, Section 6.8]
|
||||
signal ;[SSH-CONNECT, Section 6.9]
|
||||
exit-status ;[SSH-CONNECT, Section 6.10]
|
||||
exit-signal ;[SSH-CONNECT, Section 6.10]
|
||||
))
|
||||
|
||||
;; The following table lists the initial assignments of the Signal
|
||||
;; Names.
|
||||
(define ssh-signal-names '(
|
||||
;; Signal Reference
|
||||
;; ------ ---------
|
||||
ABRT ;[SSH-CONNECT]
|
||||
ALRM ;[SSH-CONNECT]
|
||||
FPE ;[SSH-CONNECT]
|
||||
HUP ;[SSH-CONNECT]
|
||||
ILL ;[SSH-CONNECT]
|
||||
INT ;[SSH-CONNECT]
|
||||
KILL ;[SSH-CONNECT]
|
||||
PIPE ;[SSH-CONNECT]
|
||||
QUIT ;[SSH-CONNECT]
|
||||
SEGV ;[SSH-CONNECT]
|
||||
TERM ;[SSH-CONNECT]
|
||||
USR1 ;[SSH-CONNECT]
|
||||
USR2 ;[SSH-CONNECT]
|
||||
))
|
||||
|
||||
;; The following table identifies the initial assignments of the key
|
||||
;; exchange methods.
|
||||
(define ssh-key-exchange-method-names '(
|
||||
;; Method name Reference
|
||||
;; ------------ ---------
|
||||
diffie-hellman-group1-sha1 ;[SSH-TRANS, Section 8.1]
|
||||
diffie-hellman-group14-sha1 ;[SSH-TRANS, Section 8.2]
|
||||
))
|
||||
|
||||
;; The following table identifies the initial assignment of the
|
||||
;; Encryption Algorithm Names.
|
||||
(define ssh-encryption-algorithm-names '(
|
||||
;; Encryption Algorithm Name Reference
|
||||
;; ------------------------- ---------
|
||||
3des-cbc ;[SSH-TRANS, Section 6.3]
|
||||
blowfish-cbc ;[SSH-TRANS, Section 6.3]
|
||||
twofish256-cbc ;[SSH-TRANS, Section 6.3]
|
||||
twofish-cbc ;[SSH-TRANS, Section 6.3]
|
||||
twofish192-cbc ;[SSH-TRANS, Section 6.3]
|
||||
twofish128-cbc ;[SSH-TRANS, Section 6.3]
|
||||
aes256-cbc ;[SSH-TRANS, Section 6.3]
|
||||
aes192-cbc ;[SSH-TRANS, Section 6.3]
|
||||
aes128-cbc ;[SSH-TRANS, Section 6.3]
|
||||
serpent256-cbc ;[SSH-TRANS, Section 6.3]
|
||||
serpent192-cbc ;[SSH-TRANS, Section 6.3]
|
||||
serpent128-cbc ;[SSH-TRANS, Section 6.3]
|
||||
arcfour ;[SSH-TRANS, Section 6.3]
|
||||
idea-cbc ;[SSH-TRANS, Section 6.3]
|
||||
cast128-cbc ;[SSH-TRANS, Section 6.3]
|
||||
none ;[SSH-TRANS, Section 6.3]
|
||||
des-cbc ;[FIPS-46-3] HISTORIC; See
|
||||
; page 4 of [FIPS-46-3]
|
||||
;; (From RFC 4344):
|
||||
aes128-ctr ;RECOMMENDED AES (Rijndael) in SDCTR mode,
|
||||
; with 128-bit key
|
||||
aes192-ctr ;RECOMMENDED AES with 192-bit key
|
||||
aes256-ctr ;RECOMMENDED AES with 256-bit key
|
||||
3des-ctr ;RECOMMENDED Three-key 3DES in SDCTR mode
|
||||
blowfish-ctr ;OPTIONAL Blowfish in SDCTR mode
|
||||
twofish128-ctr ;OPTIONAL Twofish in SDCTR mode,
|
||||
; with 128-bit key
|
||||
twofish192-ctr ;OPTIONAL Twofish with 192-bit key
|
||||
twofish256-ctr ;OPTIONAL Twofish with 256-bit key
|
||||
serpent128-ctr ;OPTIONAL Serpent in SDCTR mode, with
|
||||
; 128-bit key
|
||||
serpent192-ctr ;OPTIONAL Serpent with 192-bit key
|
||||
serpent256-ctr ;OPTIONAL Serpent with 256-bit key
|
||||
idea-ctr ;OPTIONAL IDEA in SDCTR mode
|
||||
cast128-ctr ;OPTIONAL CAST-128 in SDCTR mode,
|
||||
; with 128-bit key
|
||||
))
|
||||
|
||||
;; The following table identifies the initial assignments of the MAC
|
||||
;; Algorithm Names.
|
||||
(define ssh-mac-algorithm-names '(
|
||||
;; MAC Algorithm Name Reference
|
||||
;; ------------------ ---------
|
||||
hmac-sha1 ;[SSH-TRANS, Section 6.4]
|
||||
hmac-sha1-96 ;[SSH-TRANS, Section 6.4]
|
||||
hmac-md5 ;[SSH-TRANS, Section 6.4]
|
||||
hmac-md5-96 ;[SSH-TRANS, Section 6.4]
|
||||
none ;[SSH-TRANS, Section 6.4]
|
||||
))
|
||||
|
||||
;; The following table identifies the initial assignments of the Public
|
||||
;; Key Algorithm names.
|
||||
(define ssh-public-key-algorithm-names '(
|
||||
;; Public Key Algorithm Name Reference
|
||||
;; ------------------------- ---------
|
||||
ssh-dss ;[SSH-TRANS, Section 6.6]
|
||||
ssh-rsa ;[SSH-TRANS, Section 6.6]
|
||||
pgp-sign-rsa ;[SSH-TRANS, Section 6.6]
|
||||
pgp-sign-dss ;[SSH-TRANS, Section 6.6]
|
||||
))
|
||||
|
||||
;; The following table identifies the initial assignments of the
|
||||
;; Compression Algorithm names.
|
||||
(define ssh-compression-algorithm-names '(
|
||||
;; Compression Algorithm Name Reference
|
||||
;; -------------------------- ---------
|
||||
none ;[SSH-TRANS, Section 6.2]
|
||||
zlib ;[SSH-TRANS, Section 6.2]
|
||||
))
|
|
@ -0,0 +1,904 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (planet tonyg/bitsyntax))
|
||||
(require (planet vyzo/crypto:2:3))
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
||||
(require "oakley-groups.rkt")
|
||||
|
||||
(require "ssh-host-key.rkt")
|
||||
|
||||
(require "ssh-numbers.rkt")
|
||||
(require "ssh-message-types.rkt")
|
||||
(require "ssh-exceptions.rkt")
|
||||
(require "ssh-transport.rkt")
|
||||
(require "ssh-channel.rkt")
|
||||
|
||||
(require "marketplace-support.rkt")
|
||||
|
||||
(provide rekey-interval
|
||||
rekey-volume
|
||||
ssh-session)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Data definitions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; A RekeyState is one of
|
||||
;; - a (rekey-wait Number Number), representing a time or
|
||||
;; transfer-amount by which rekeying should be started
|
||||
;; - a (rekey-local SshMsgKexinit), when we've sent our local
|
||||
;; algorithm list and are waiting for the other party to send theirs
|
||||
;; - a (rekey-in-progress KeyExchangeState), when both our local
|
||||
;; algorithm list has been sent and the remote one has arrived and the
|
||||
;; actual key exchange has begun
|
||||
(struct rekey-wait (deadline threshold-bytes) #:transparent)
|
||||
(struct rekey-local (local-algorithms) #:transparent)
|
||||
(struct rekey-in-progress (state) #:transparent)
|
||||
|
||||
;; An AuthenticationState is one of
|
||||
;; - #f, for not-yet-authenticated
|
||||
;; - an (authenticated String String), recording successful completion
|
||||
;; of the authentication protocol after a request to be identified
|
||||
;; as the given username for the given service.
|
||||
;; TODO: When authentication is properly implemented, we will need
|
||||
;; intermediate states here too.
|
||||
(struct authenticated (username service) #:transparent)
|
||||
|
||||
;; A PacketDispatcher is a Hashtable mapping Byte to PacketHandler.
|
||||
|
||||
;; A PacketHandler is a (Bytes DecodedPacket ConnectionState -> Transition).
|
||||
;; The raw received bytes of the packet are given because sometimes
|
||||
;; cryptographic operations on the received bytes are mandated by the
|
||||
;; protocol.
|
||||
|
||||
;; TODO: Remove dispatch-table in favour of using the os2 subscription
|
||||
;; mechanism to dispatch packets. I could do this now, but I'd lose
|
||||
;; SSH_MSG_UNIMPLEMENTED support: I would need to be able to query the
|
||||
;; current routing table to see whether there was an active listener
|
||||
;; ready to take a given packet.
|
||||
|
||||
;; A ConnectionState is a (connection ... TODO fix this) representing
|
||||
;; the complete state of the SSH transport, authentication, and
|
||||
;; connection layers.
|
||||
(struct connection (discard-next-packet?
|
||||
dispatch-table
|
||||
total-transferred
|
||||
rekey-state
|
||||
authentication-state
|
||||
channels ;; ListOf<ChannelState>
|
||||
is-server?
|
||||
local-id
|
||||
remote-id
|
||||
session-id ;; starts off #f until initial keying
|
||||
application-boot) ;; used when authentication completes
|
||||
#: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.
|
||||
(struct exchange-hash-info (client-id
|
||||
server-id
|
||||
client-kexinit-bytes
|
||||
server-kexinit-bytes)
|
||||
#:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Parameters
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define rekey-interval (make-parameter 3600))
|
||||
(define rekey-volume (make-parameter 1000000000))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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))
|
||||
|
||||
;; PacketDispatcher [ Byte Maybe<PacketHandler> ]* -> 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))))))
|
||||
|
||||
;; ConnectionState [ Byte Maybe<PacketHandler> ]* -> 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)]))
|
||||
|
||||
;; Transition 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 (dispatch-packet seq packet message conn)
|
||||
(define packet-type-number (encoded-packet-msg-type packet))
|
||||
(if (and (not (rekey-wait? (connection-rekey-state conn)))
|
||||
(or (not (ssh-msg-type-transport-layer? packet-type-number))
|
||||
(= packet-type-number SSH_MSG_SERVICE_REQUEST)
|
||||
(= packet-type-number SSH_MSG_SERVICE_ACCEPT)))
|
||||
;; We're in the middle of some phase of an active key-exchange,
|
||||
;; and received a packet that's for a higher layer than the
|
||||
;; transport layer, or one of the forbidden types given at the
|
||||
;; send of RFC4253 section 7.1.
|
||||
(disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
|
||||
"Packets of type ~v forbidden while in key-exchange"
|
||||
packet-type-number)
|
||||
;; We're either idling, or it's a permitted packet type while
|
||||
;; performing key exchange. Look it up in the dispatch table.
|
||||
(let ((handler (hash-ref (connection-dispatch-table conn)
|
||||
packet-type-number
|
||||
#f)))
|
||||
(if handler
|
||||
(handler packet message conn)
|
||||
(transition conn
|
||||
(send-message (outbound-packet (ssh-msg-unimplemented seq))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Handlers for core transport packet types
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; PacketHandler for handling SSH_MSG_DISCONNECT.
|
||||
(define (handle-msg-disconnect packet message conn)
|
||||
(disconnect-with-error* #t
|
||||
'()
|
||||
(ssh-msg-disconnect-reason-code message)
|
||||
"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)))))
|
||||
|
||||
;; PacketHandler for handling SSH_MSG_IGNORE.
|
||||
(define (handle-msg-ignore packet message conn)
|
||||
(transition conn))
|
||||
|
||||
;; 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."))
|
||||
|
||||
;; PacketHandler for handling SSH_MSG_DEBUG.
|
||||
(define (handle-msg-debug packet message conn)
|
||||
(log-debug (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message))
|
||||
(transition conn))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Key Exchange
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (rekey-in-seconds-or-bytes delta-seconds delta-bytes total-transferred)
|
||||
(rekey-wait (+ (current-seconds) delta-seconds)
|
||||
(+ total-transferred delta-bytes)))
|
||||
|
||||
(define (time-to-rekey? rekey conn)
|
||||
(and (rekey-wait? rekey)
|
||||
(or (>= (current-seconds) (rekey-wait-deadline rekey))
|
||||
(>= (connection-total-transferred conn) (rekey-wait-threshold-bytes rekey)))))
|
||||
|
||||
;; (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))
|
||||
(let loop ((client-list client-list0))
|
||||
(cond
|
||||
((null? client-list) (disconnect-with-error/local-info
|
||||
`((client-list ,client-list0)
|
||||
(server-list ,server-list))
|
||||
SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
||||
"Could not agree on a suitable algorithm for ~v"
|
||||
getter))
|
||||
((memq (car client-list) server-list) (car client-list))
|
||||
(else (loop (cdr client-list))))))
|
||||
|
||||
;; 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 ((exchange-hash-info-client-id hash-info) :: (t:string))
|
||||
((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))))))
|
||||
(sha1 block-to-hash)))
|
||||
|
||||
;; ExchangeHashInfo Symbol Symbol ConnectionState
|
||||
;; (Bytes Bytes Symbol ConnectionState -> ConnectionState)
|
||||
;; -> Transition
|
||||
;; Performs the server's half of the Diffie-Hellman key exchange protocol.
|
||||
(define (perform-server-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))
|
||||
(define public-key-as-integer (bit-string->integer public-key #t #f))
|
||||
(transition
|
||||
(oneshot-handler conn
|
||||
SSH_MSG_KEXDH_INIT
|
||||
(lambda (packet message conn)
|
||||
(define e (ssh-msg-kexdh-init-e message))
|
||||
(define e-width (mpint-width e))
|
||||
(define e-as-bytes (integer->bit-string e (* 8 e-width) #t))
|
||||
(define shared-secret (compute-key private-key e-as-bytes))
|
||||
(define hash-alg sha1)
|
||||
(define-values (host-key-private host-key-public)
|
||||
(host-key-algorithm->keys host-key-alg))
|
||||
(define host-key-bytes
|
||||
(pieces->ssh-host-key (public-key->pieces host-key-public)))
|
||||
(define exchange-hash
|
||||
(dh-exchange-hash hash-info
|
||||
host-key-bytes
|
||||
e
|
||||
public-key-as-integer
|
||||
(bit-string->integer shared-secret #t #f)))
|
||||
(define h-signature (host-key-signature host-key-private
|
||||
host-key-alg
|
||||
exchange-hash))
|
||||
(sequence-actions (transition conn)
|
||||
(send-message (outbound-packet
|
||||
(ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
|
||||
public-key-as-integer
|
||||
(bit-string->bytes h-signature))))
|
||||
(lambda (conn)
|
||||
(finish shared-secret exchange-hash hash-alg conn))))))]
|
||||
[else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
||||
"Bad key-exchange algorithm ~v" kex-alg)]))
|
||||
|
||||
;; ExchangeHashInfo Symbol Symbol ConnectionState
|
||||
;; (Bytes Bytes Symbol ConnectionState -> ConnectionState)
|
||||
;; -> Transition
|
||||
;; 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))
|
||||
(define public-key-as-integer (bit-string->integer public-key #t #f))
|
||||
(sequence-actions (transition conn)
|
||||
(send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer)))
|
||||
(lambda (conn)
|
||||
(transition
|
||||
(oneshot-handler conn
|
||||
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 host-key-bytes (ssh-msg-kexdh-reply-host-key message))
|
||||
(define host-public-key
|
||||
(pieces->public-key (ssh-host-key->pieces host-key-bytes)))
|
||||
(define exchange-hash
|
||||
(dh-exchange-hash hash-info
|
||||
host-key-bytes
|
||||
public-key-as-integer
|
||||
f
|
||||
(bit-string->integer shared-secret #t #f)))
|
||||
(verify-host-key-signature! host-public-key
|
||||
host-key-alg
|
||||
exchange-hash
|
||||
(ssh-msg-kexdh-reply-h-signature
|
||||
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)]))
|
||||
|
||||
;; 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)
|
||||
|
||||
(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))
|
||||
(define c2s-enc (best-result ssh-msg-kexinit-encryption_algorithms_client_to_server c s))
|
||||
(define s2c-enc (best-result ssh-msg-kexinit-encryption_algorithms_server_to_client c s))
|
||||
(define c2s-mac (best-result ssh-msg-kexinit-mac_algorithms_client_to_server c s))
|
||||
(define s2c-mac (best-result ssh-msg-kexinit-mac_algorithms_server_to_client c s))
|
||||
(define c2s-zip (best-result ssh-msg-kexinit-compression_algorithms_client_to_server c s))
|
||||
(define s2c-zip (best-result ssh-msg-kexinit-compression_algorithms_server_to_client c s))
|
||||
;; Ignore languages.
|
||||
;; Don't check the reserved field here, either. TODO: should we?
|
||||
|
||||
(define (guess-matches? chosen-value getter)
|
||||
(let ((remote-choices (getter remote-algs)))
|
||||
(and (pair? remote-choices) ;; not strictly necessary because of
|
||||
;; the error behaviour of
|
||||
;; best-result.
|
||||
(eq? (car remote-choices) ;; the remote peer's guess for this parameter
|
||||
chosen-value))))
|
||||
|
||||
(define should-discard-first-kex-packet
|
||||
(and (ssh-msg-kexinit-first_kex_packet_follows remote-algs)
|
||||
;; They've already transmitted their guess. Does their guess match
|
||||
;; what we've actually selected?
|
||||
(not (and
|
||||
(guess-matches? kex-alg ssh-msg-kexinit-kex_algorithms)
|
||||
(guess-matches? host-key-alg ssh-msg-kexinit-server_host_key_algorithms)
|
||||
(guess-matches? c2s-enc ssh-msg-kexinit-encryption_algorithms_client_to_server)
|
||||
(guess-matches? s2c-enc ssh-msg-kexinit-encryption_algorithms_server_to_client)
|
||||
(guess-matches? c2s-mac ssh-msg-kexinit-mac_algorithms_client_to_server)
|
||||
(guess-matches? s2c-mac ssh-msg-kexinit-mac_algorithms_server_to_client)
|
||||
(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 conn)
|
||||
((if is-server?
|
||||
perform-server-key-exchange
|
||||
perform-client-key-exchange)
|
||||
(if is-server?
|
||||
(exchange-hash-info (connection-remote-id conn)
|
||||
(connection-local-id conn)
|
||||
encoded-remote-algs
|
||||
encoded-local-algs)
|
||||
(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 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
|
||||
((eq? #f 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))))))))))
|
||||
(transition
|
||||
(oneshot-handler (struct-copy connection conn
|
||||
[session-id session-id]) ;; just in case it changed
|
||||
SSH_MSG_NEWKEYS
|
||||
(lambda (newkeys-packet newkeys-message conn)
|
||||
;; First, send our SSH_MSG_NEWKEYS,
|
||||
;; incrementing the various counters, and then
|
||||
;; apply the new algorithms. Also arm our rekey
|
||||
;; timer.
|
||||
(define new-rekey-state (rekey-in-seconds-or-bytes
|
||||
(rekey-interval)
|
||||
(rekey-volume)
|
||||
(connection-total-transferred conn)))
|
||||
(transition
|
||||
(set-handlers
|
||||
(struct-copy connection conn [rekey-state new-rekey-state])
|
||||
SSH_MSG_SERVICE_REQUEST handle-msg-service-request)
|
||||
(send-message (outbound-packet (ssh-msg-newkeys)))
|
||||
(send-message
|
||||
(new-keys (connection-is-server? conn)
|
||||
derive-key
|
||||
c2s-enc s2c-enc
|
||||
c2s-mac s2c-mac
|
||||
c2s-zip s2c-zip))
|
||||
(send-message (set-timer 'rekey-timer
|
||||
(* (rekey-wait-deadline new-rekey-state) 1000)
|
||||
'absolute)))))))
|
||||
|
||||
(sequence-actions (continue-after-discard conn)
|
||||
(when should-discard-first-kex-packet
|
||||
(lambda (conn) (transition (struct-copy connection conn [discard-next-packet? #t]))))
|
||||
(lambda (conn)
|
||||
(if (rekey-wait? (connection-rekey-state conn))
|
||||
(transition (struct-copy connection conn [rekey-state (rekey-local local-algs)])
|
||||
(send-message (outbound-packet local-algs)))
|
||||
(transition conn)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Service request manager
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (handle-msg-service-request packet message conn)
|
||||
(define service (bit-string->bytes (ssh-msg-service-request-service-name message)))
|
||||
(match service
|
||||
[#"ssh-userauth"
|
||||
(if (connection-authentication-state conn)
|
||||
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
||||
"Repeated authentication is not permitted")
|
||||
(sequence-actions (transition conn)
|
||||
(send-message (outbound-packet (ssh-msg-service-accept service)))
|
||||
(lambda (conn) (transition
|
||||
(oneshot-handler conn
|
||||
SSH_MSG_USERAUTH_REQUEST
|
||||
handle-msg-userauth-request)))))]
|
||||
[else
|
||||
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
||||
"Service ~v not supported"
|
||||
service)]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; User authentication
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (handle-msg-userauth-request packet message conn)
|
||||
(define user-name (bit-string->bytes (ssh-msg-userauth-request-user-name message)))
|
||||
(define service-name (bit-string->bytes (ssh-msg-userauth-request-service-name message)))
|
||||
(cond
|
||||
[(and (positive? (bytes-length user-name))
|
||||
(equal? service-name #"ssh-connection"))
|
||||
;; TODO: Actually implement client authentication
|
||||
(sequence-actions (transition conn)
|
||||
(send-message (outbound-packet (ssh-msg-userauth-success)))
|
||||
(lambda (conn)
|
||||
(start-connection-service
|
||||
(set-handlers (struct-copy connection conn
|
||||
[authentication-state (authenticated user-name service-name)])
|
||||
SSH_MSG_USERAUTH_REQUEST
|
||||
(lambda (packet message conn)
|
||||
;; RFC4252 section 5.1 page 6
|
||||
conn))))
|
||||
(lambda (conn)
|
||||
(transition conn
|
||||
;; TODO: canary for NESTED VM!: #:exit-signal? #t
|
||||
(nested-vm #:debug-name 'ssh-application-vm
|
||||
((connection-application-boot conn) user-name)))))]
|
||||
[else
|
||||
(transition conn
|
||||
(send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Channel management
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (unused-local-channel-ref conn)
|
||||
(define (bump-candidate candidate)
|
||||
(modulo (+ candidate 1) #x100000000))
|
||||
(define first-candidate (match (connection-channels conn)
|
||||
['() 0]
|
||||
[(cons ch _) (bump-candidate (ssh-channel-local-ref ch))]))
|
||||
(let examine-candidate ((candidate first-candidate))
|
||||
(let loop ((chs (connection-channels conn)))
|
||||
(cond
|
||||
[(null? chs) candidate]
|
||||
[(= (ssh-channel-local-ref (car chs)) candidate)
|
||||
(examine-candidate (bump-candidate candidate))]
|
||||
[else (loop (cdr chs))]))))
|
||||
|
||||
(define (replacef proc updater creator lst)
|
||||
(let loop ((lst lst))
|
||||
(cond [(null? lst) (list (creator))]
|
||||
[(proc (car lst)) (cons (updater (car lst)) (cdr lst))]
|
||||
[else (cons (car lst) (loop (cdr lst)))])))
|
||||
|
||||
(define (remf proc lst)
|
||||
(cond [(null? lst) '()]
|
||||
[(proc (car lst)) (cdr lst)]
|
||||
[else (cons (car lst) (remf proc (cdr lst)))]))
|
||||
|
||||
;; ChannelName -> ChannelState -> Boolean
|
||||
(define ((ssh-channel-name=? cname) c)
|
||||
(equal? (ssh-channel-name c) cname))
|
||||
|
||||
;; Connection Uint32 -> ChannelState
|
||||
(define (get-channel conn local-ref)
|
||||
(define ch (findf (lambda (c) (equal? (ssh-channel-local-ref c) local-ref))
|
||||
(connection-channels conn)))
|
||||
(when (not ch)
|
||||
(disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
|
||||
"Attempt to use known channel local-ref ~v"
|
||||
local-ref))
|
||||
ch)
|
||||
|
||||
;; ChannelName Maybe<Uint32> Connection -> Connection
|
||||
(define (update-channel cname updater conn)
|
||||
(struct-copy connection conn
|
||||
[channels
|
||||
(replacef (ssh-channel-name=? cname)
|
||||
updater
|
||||
(lambda () (updater (ssh-channel cname
|
||||
(unused-local-channel-ref conn)
|
||||
#f
|
||||
#f
|
||||
'neither)))
|
||||
(connection-channels conn))]))
|
||||
|
||||
;; ChannelName Connection -> Connection
|
||||
(define (discard-channel cname conn)
|
||||
(struct-copy connection conn
|
||||
[channels
|
||||
(remf (ssh-channel-name=? cname) (connection-channels conn))]))
|
||||
|
||||
;; CloseState Either<'local,'remote> -> CloseState
|
||||
(define (update-close-state old-state action)
|
||||
(define local? (case action ((local) #t) ((remote) #f)))
|
||||
(case old-state
|
||||
((neither) (if local? 'local 'remote))
|
||||
((local) (if local? 'local 'both))
|
||||
((remote) (if local? 'both 'remote))
|
||||
((both) 'both)))
|
||||
|
||||
(define (maybe-close-channel cname conn action)
|
||||
(cond
|
||||
[(findf (ssh-channel-name=? cname) (connection-channels conn)) =>
|
||||
(lambda (ch)
|
||||
(define old-close-state (ssh-channel-close-state ch))
|
||||
(define new-close-state (update-close-state old-close-state action))
|
||||
(transition (if (eq? new-close-state 'both)
|
||||
(discard-channel ch conn)
|
||||
(update-channel cname
|
||||
(lambda (ch)
|
||||
(struct-copy ssh-channel ch
|
||||
[close-state new-close-state]))
|
||||
conn))
|
||||
(case action
|
||||
[(local)
|
||||
(case old-close-state
|
||||
[(neither remote)
|
||||
(list (send-message (outbound-packet
|
||||
(ssh-msg-channel-close (ssh-channel-remote-ref ch)))))]
|
||||
[else (list)])]
|
||||
[(remote)
|
||||
(case old-close-state
|
||||
[(neither local)
|
||||
(list (delete-endpoint (list cname 'outbound))
|
||||
(delete-endpoint (list cname 'inbound)))]
|
||||
[else (list)])])))]
|
||||
[else (transition conn)]))
|
||||
|
||||
(define (channel-endpoints cname initial-message-producer)
|
||||
(define inbound-stream-name (channel-stream-name #t cname))
|
||||
(define outbound-stream-name (channel-stream-name #f cname))
|
||||
(define (! conn message)
|
||||
(transition conn (send-message (outbound-packet message))))
|
||||
(list
|
||||
(endpoint #:subscriber (channel-message outbound-stream-name (wild))
|
||||
#:name (list cname 'outbound)
|
||||
#:state conn
|
||||
#:on-presence (transition conn
|
||||
(initial-message-producer inbound-stream-name outbound-stream-name))
|
||||
#:on-absence (maybe-close-channel cname conn 'local)
|
||||
[(channel-message _ body)
|
||||
(let ()
|
||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||
(define remote-ref (ssh-channel-remote-ref ch))
|
||||
(match body
|
||||
[(channel-stream-data data-bytes)
|
||||
;; TODO: split data-bytes into packets if longer than max packet size
|
||||
(! conn (ssh-msg-channel-data remote-ref data-bytes))]
|
||||
[(channel-stream-extended-data type data-bytes)
|
||||
(! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))]
|
||||
[(channel-stream-eof)
|
||||
(! conn (ssh-msg-channel-eof remote-ref))]
|
||||
[(channel-stream-notify type data-bytes)
|
||||
(! conn (ssh-msg-channel-request remote-ref type #f data-bytes))]
|
||||
[(channel-stream-request type data-bytes)
|
||||
(! conn (ssh-msg-channel-request remote-ref type #t data-bytes))]
|
||||
[(channel-stream-open-failure reason description)
|
||||
(! (discard-channel cname conn)
|
||||
(ssh-msg-channel-open-failure remote-ref reason description #""))]))])
|
||||
(endpoint #:publisher (channel-message inbound-stream-name (wild))
|
||||
#:name (list cname 'inbound)
|
||||
#:state conn
|
||||
[(channel-message _ body)
|
||||
(let ()
|
||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||
(define remote-ref (ssh-channel-remote-ref ch))
|
||||
(match body
|
||||
[(channel-stream-config maximum-packet-size extra-data)
|
||||
(if (channel-name-locally-originated? cname)
|
||||
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN.
|
||||
(! conn (ssh-msg-channel-open (channel-name-type cname)
|
||||
(ssh-channel-local-ref ch)
|
||||
0
|
||||
maximum-packet-size
|
||||
extra-data))
|
||||
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION.
|
||||
(! conn (ssh-msg-channel-open-confirmation remote-ref
|
||||
(ssh-channel-local-ref ch)
|
||||
0
|
||||
maximum-packet-size
|
||||
extra-data)))]
|
||||
[(channel-stream-credit count)
|
||||
(! conn (ssh-msg-channel-window-adjust remote-ref count))]
|
||||
[(channel-stream-ok)
|
||||
(! conn (ssh-msg-channel-success remote-ref))]
|
||||
[(channel-stream-fail)
|
||||
(! conn (ssh-msg-channel-failure remote-ref))]))])))
|
||||
|
||||
(define (channel-notify conn ch inbound? body)
|
||||
(transition conn
|
||||
(send-message (channel-message (channel-stream-name inbound? (ssh-channel-name ch))
|
||||
body)
|
||||
(if inbound? 'publisher 'subscriber))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Connection service
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (respond-to-opened-outbound-channel conn cname)
|
||||
(if (and (ground? cname)
|
||||
(not (memf (ssh-channel-name=? cname) (connection-channels conn))))
|
||||
(transition (update-channel cname values conn)
|
||||
(channel-endpoints cname (lambda (inbound-stream outbound-stream)
|
||||
'())))
|
||||
(transition conn)))
|
||||
|
||||
(define (start-connection-service conn)
|
||||
(sequence-actions
|
||||
(transition
|
||||
(set-handlers conn
|
||||
;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request
|
||||
SSH_MSG_CHANNEL_OPEN handle-msg-channel-open
|
||||
SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation
|
||||
SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure
|
||||
SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust
|
||||
SSH_MSG_CHANNEL_DATA handle-msg-channel-data
|
||||
SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data
|
||||
SSH_MSG_CHANNEL_EOF handle-msg-channel-eof
|
||||
SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close
|
||||
SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request
|
||||
SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success
|
||||
SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure))
|
||||
;; Start responding to channel interest coming from the
|
||||
;; application. We are responding to channels appearing from the
|
||||
;; remote peer by virtue of our installation of the handler for
|
||||
;; SSH_MSG_CHANNEL_OPEN above.
|
||||
(endpoint #:publisher (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
|
||||
#:observer
|
||||
#:state conn
|
||||
#:conversation (channel-message (channel-stream-name #t cname) _)
|
||||
#:on-presence (respond-to-opened-outbound-channel conn cname))
|
||||
(endpoint #:subscriber (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
|
||||
#:observer
|
||||
#:state conn
|
||||
#:conversation (channel-message (channel-stream-name #f cname) _)
|
||||
#:on-presence (respond-to-opened-outbound-channel conn cname))))
|
||||
|
||||
(define (handle-msg-channel-open packet message conn)
|
||||
(match-define (ssh-msg-channel-open channel-type*
|
||||
remote-ref
|
||||
initial-window-size
|
||||
maximum-packet-size
|
||||
extra-request-data*)
|
||||
message)
|
||||
|
||||
(when (memf (lambda (c) (equal? (ssh-channel-remote-ref c) remote-ref))
|
||||
(connection-channels conn))
|
||||
(disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
|
||||
"Attempt to open already-open channel ~v"
|
||||
remote-ref))
|
||||
|
||||
(define channel-type (bit-string->bytes channel-type*))
|
||||
(define extra-request-data (bit-string->bytes extra-request-data*))
|
||||
(define cname (channel-name #f channel-type remote-ref))
|
||||
|
||||
(transition (update-channel cname
|
||||
(lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref]))
|
||||
conn)
|
||||
(channel-endpoints cname
|
||||
(lambda (inbound-stream outbound-stream)
|
||||
(list (send-feedback
|
||||
(channel-message outbound-stream
|
||||
(channel-stream-config maximum-packet-size
|
||||
extra-request-data)))
|
||||
(send-feedback
|
||||
(channel-message outbound-stream
|
||||
(channel-stream-credit initial-window-size))))))))
|
||||
|
||||
(define (handle-msg-channel-open-confirmation packet message conn)
|
||||
(match-define (ssh-msg-channel-open-confirmation local-ref
|
||||
remote-ref
|
||||
initial-window-size
|
||||
maximum-packet-size
|
||||
extra-request-data*)
|
||||
message)
|
||||
(define ch (get-channel conn local-ref))
|
||||
(define extra-request-data (bit-string->bytes extra-request-data*))
|
||||
(define outbound-stream (channel-stream-name #f (ssh-channel-name ch)))
|
||||
(transition (update-channel (ssh-channel-name ch)
|
||||
(lambda (c)
|
||||
(struct-copy ssh-channel c
|
||||
[remote-ref remote-ref]
|
||||
[outbound-packet-size maximum-packet-size]))
|
||||
conn)
|
||||
(send-feedback (channel-message outbound-stream
|
||||
(channel-stream-config maximum-packet-size
|
||||
extra-request-data)))
|
||||
(send-feedback (channel-message outbound-stream
|
||||
(channel-stream-credit initial-window-size)))))
|
||||
|
||||
(define (handle-msg-channel-open-failure packet message conn)
|
||||
(match-define (ssh-msg-channel-open-failure local-ref
|
||||
reason
|
||||
description*
|
||||
_)
|
||||
message)
|
||||
(define ch (get-channel conn local-ref))
|
||||
(define description (bit-string->bytes description*))
|
||||
(define inbound-stream (channel-stream-name #t (ssh-channel-name ch)))
|
||||
(sequence-actions (transition conn)
|
||||
(send-message (channel-message inbound-stream
|
||||
(channel-stream-open-failure reason description)))
|
||||
(lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote))))
|
||||
|
||||
(define (handle-msg-channel-window-adjust packet message conn)
|
||||
(match-define (ssh-msg-channel-window-adjust local-ref count) message)
|
||||
(define ch (get-channel conn local-ref))
|
||||
(channel-notify conn ch #f (channel-stream-credit count)))
|
||||
|
||||
(define (handle-msg-channel-data packet message conn)
|
||||
(match-define (ssh-msg-channel-data local-ref data*) message)
|
||||
(define data (bit-string->bytes data*))
|
||||
(define ch (get-channel conn local-ref))
|
||||
(channel-notify conn ch #t (channel-stream-data data)))
|
||||
|
||||
(define (handle-msg-channel-extended-data packet message conn)
|
||||
(match-define (ssh-msg-channel-extended-data local-ref type-code data*) message)
|
||||
(define data (bit-string->bytes data*))
|
||||
(define ch (get-channel conn local-ref))
|
||||
(channel-notify conn ch #t (channel-stream-extended-data type-code data)))
|
||||
|
||||
(define (handle-msg-channel-eof packet message conn)
|
||||
(define ch (get-channel conn (ssh-msg-channel-eof-recipient-channel message)))
|
||||
(channel-notify conn ch #t (channel-stream-eof)))
|
||||
|
||||
(define (handle-msg-channel-close packet message conn)
|
||||
(define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message)))
|
||||
(maybe-close-channel (ssh-channel-name ch) conn 'remote))
|
||||
|
||||
(define (handle-msg-channel-request packet message conn)
|
||||
(match-define (ssh-msg-channel-request local-ref type* want-reply? data*) message)
|
||||
(define type (bit-string->bytes type*))
|
||||
(define data (bit-string->bytes data*))
|
||||
(define ch (get-channel conn local-ref))
|
||||
(channel-notify conn ch #t
|
||||
(if want-reply?
|
||||
(channel-stream-request type data)
|
||||
(channel-stream-notify type data))))
|
||||
|
||||
(define (handle-msg-channel-success packet message conn)
|
||||
(match-define (ssh-msg-channel-success local-ref) message)
|
||||
(define ch (get-channel conn local-ref))
|
||||
(channel-notify conn ch #f (channel-stream-ok)))
|
||||
|
||||
(define (handle-msg-channel-failure packet message conn)
|
||||
(match-define (ssh-msg-channel-failure local-ref) message)
|
||||
(define ch (get-channel conn local-ref))
|
||||
(channel-notify conn ch #f (channel-stream-fail)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Session main process
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (connection-username conn)
|
||||
(match (connection-authentication-state conn)
|
||||
((authenticated username servicename)
|
||||
username)
|
||||
(else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
|
||||
"Not authenticated"))))
|
||||
|
||||
(define ((bump-total amount) conn)
|
||||
(transition
|
||||
(struct-copy connection conn
|
||||
[total-transferred (+ (connection-total-transferred conn) amount)])))
|
||||
|
||||
;; (K V A -> A) A Hash<K,V> -> A
|
||||
(define (hash-fold fn seed hash)
|
||||
(do ((pos (hash-iterate-first hash) (hash-iterate-next hash pos))
|
||||
(seed seed (fn (hash-iterate-key hash pos) (hash-iterate-value hash pos) seed)))
|
||||
((not pos) seed)))
|
||||
|
||||
(define (maybe-rekey conn)
|
||||
(define rekey (connection-rekey-state conn))
|
||||
(if (time-to-rekey? rekey conn)
|
||||
(let ((algs ((local-algorithm-list))))
|
||||
(transition (struct-copy connection conn [rekey-state (rekey-local algs)])
|
||||
(send-message (outbound-packet algs))))
|
||||
(transition conn)))
|
||||
|
||||
;; 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 (ssh-session self-pid
|
||||
local-identification-string
|
||||
peer-identification-string
|
||||
application-boot
|
||||
session-role)
|
||||
(transition (connection #f
|
||||
base-packet-dispatcher
|
||||
0
|
||||
(rekey-in-seconds-or-bytes -1 -1 0)
|
||||
#f
|
||||
'()
|
||||
(case session-role ((client) #f) ((server) #t))
|
||||
local-identification-string
|
||||
peer-identification-string
|
||||
#f
|
||||
application-boot)
|
||||
|
||||
(endpoint #:subscriber (timer-expired 'rekey-timer (wild))
|
||||
#:state conn
|
||||
[(timer-expired 'rekey-timer now)
|
||||
(sequence-actions (transition conn)
|
||||
maybe-rekey)])
|
||||
|
||||
(endpoint #:subscriber (outbound-byte-credit (wild))
|
||||
#:state conn
|
||||
[(outbound-byte-credit amount)
|
||||
(sequence-actions (transition conn)
|
||||
(bump-total amount)
|
||||
maybe-rekey)])
|
||||
|
||||
(endpoint #:subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||
#:state conn
|
||||
[(inbound-packet sequence-number payload message transfer-size)
|
||||
(sequence-actions (transition conn)
|
||||
(lambda (conn)
|
||||
(if (connection-discard-next-packet? conn)
|
||||
(transition
|
||||
(struct-copy connection conn [discard-next-packet? #f]))
|
||||
(dispatch-packet sequence-number payload message conn)))
|
||||
(bump-total transfer-size)
|
||||
(send-message (inbound-credit 1))
|
||||
maybe-rekey)])))
|
|
@ -0,0 +1,454 @@
|
|||
#lang racket/base
|
||||
|
||||
(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
|
||||
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?)
|
||||
#:name 'socket-reader
|
||||
#:state (and state
|
||||
(ssh-reader-state mode
|
||||
(crypto-configuration cipher
|
||||
cipher-description
|
||||
hmac
|
||||
hmac-description)
|
||||
sequence-number
|
||||
remaining-credit))
|
||||
[(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"))]))]))
|
||||
(endpoint #:subscriber (inbound-credit (wild))
|
||||
#:state state
|
||||
[(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)))])
|
||||
(endpoint #:subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild))
|
||||
#:state state
|
||||
[(? new-keys? nk)
|
||||
(transition (struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)]))])
|
||||
(endpoint #: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)
|
||||
(endpoint #:publisher (outbound-byte-credit (wild)))
|
||||
(endpoint #:subscriber (outbound-packet (wild))
|
||||
#:state (and state
|
||||
(ssh-writer-state (crypto-configuration cipher
|
||||
cipher-description
|
||||
hmac
|
||||
hmac-description)
|
||||
sequence-number))
|
||||
[(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)))))])
|
||||
(endpoint #:subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild))
|
||||
#:state state
|
||||
[(? new-keys? nk)
|
||||
(transition
|
||||
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))
|
|
@ -0,0 +1,136 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "aes-ctr.rkt")
|
||||
(require rackunit)
|
||||
(require (planet tonyg/bitsyntax))
|
||||
|
||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
||||
(aes-ctr-process! x #"abcdefghijklmnop"))
|
||||
#"\275XO-\317^<d\16(\262\257Fv}e" ;; = bd584f2dcf5e3c640e28b2af46767d65
|
||||
)
|
||||
|
||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
||||
(let* ((b1 (aes-ctr-process! x #"abcdef"))
|
||||
(b2 (aes-ctr-process! x #"ghijklmnop")))
|
||||
(list b1 b2)))
|
||||
(list #"\275XO-\317^"
|
||||
#"<d\16(\262\257Fv}e"))
|
||||
|
||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
||||
(aes-ctr-process! x #"\275XO-\317^<d\16(\262\257Fv}e"))
|
||||
#"abcdefghijklmnop")
|
||||
|
||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
||||
(let* ((b1 (aes-ctr-process! x #"\275XO-\317^"))
|
||||
(b2 (aes-ctr-process! x #"<d\16(\262\257Fv}e")))
|
||||
(list b1 b2)))
|
||||
(list #"abcdef"
|
||||
#"ghijklmnop"))
|
||||
|
||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
||||
(aes-ctr-process! x #"abcdefghijklmnopabcdefghijklmnop"))
|
||||
#"\275XO-\317^<d\16(\262\257Fv}e!v\301\23\6@\330\305\314c\27\374\276\330 \342")
|
||||
|
||||
(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
|
||||
(aes-ctr-process! x
|
||||
#"\275XO-\317^<d\16(\262\257Fv}e!v\301\23\6@\330\305\314c\27\374\276\330 \342"))
|
||||
#"abcdefghijklmnopabcdefghijklmnop")
|
||||
|
||||
;; Test vectors from http://tools.ietf.org/html/draft-ietf-ipsec-ciph-aes-ctr-05
|
||||
|
||||
(define (hex-string->bytes str) ;; grumble
|
||||
(define cleaned (regexp-replace* #rx"[^0-9a-fA-F]+" str ""))
|
||||
(define bits (* (string-length cleaned) 4))
|
||||
(define n (string->number cleaned 16))
|
||||
(integer->bit-string n bits #t))
|
||||
|
||||
(define (test-enc description key ivec plaintext ciphertext)
|
||||
(let ((state (start-aes-ctr (hex-string->bytes key)
|
||||
(hex-string->bytes ivec))))
|
||||
(check-equal? (aes-ctr-process! state (hex-string->bytes plaintext))
|
||||
(hex-string->bytes ciphertext)
|
||||
(format "test-enc ~v" description))))
|
||||
|
||||
;; Test Vector #1: Encrypting 16 octets using AES-CTR with 128-bit key
|
||||
(test-enc 1
|
||||
"AE 68 52 F8 12 10 67 CC 4B F7 A5 76 55 77 F3 9E"
|
||||
"00 00 00 30 00 00 00 00 00 00 00 00 00 00 00 01"
|
||||
"53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
|
||||
"E4 09 5D 4F B7 A7 B3 79 2D 61 75 A3 26 13 11 B8")
|
||||
|
||||
;; Test Vector #2: Encrypting 32 octets using AES-CTR with 128-bit key
|
||||
(test-enc 2
|
||||
"7E 24 06 78 17 FA E0 D7 43 D6 CE 1F 32 53 91 63"
|
||||
"00 6C B6 DB C0 54 3B 59 DA 48 D9 0B 00 00 00 01"
|
||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
|
||||
(string-append "51 04 A1 06 16 8A 72 D9 79 0D 41 EE 8E DA D3 88"
|
||||
"EB 2E 1E FC 46 DA 57 C8 FC E6 30 DF 91 41 BE 28"))
|
||||
|
||||
;; Test Vector #3: Encrypting 36 octets using AES-CTR with 128-bit key
|
||||
(test-enc 3
|
||||
"76 91 BE 03 5E 50 20 A8 AC 6E 61 85 29 F9 A0 DC"
|
||||
"00 E0 01 7B 27 77 7F 3F 4A 17 86 F0 00 00 00 01"
|
||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
|
||||
"20 21 22 23")
|
||||
(string-append "C1 CF 48 A8 9F 2F FD D9 CF 46 52 E9 EF DB 72 D7"
|
||||
"45 40 A4 2B DE 6D 78 36 D5 9A 5C EA AE F3 10 53"
|
||||
"25 B2 07 2F"))
|
||||
|
||||
;; Test Vector #4: Encrypting 16 octets using AES-CTR with 192-bit key
|
||||
(test-enc 4
|
||||
"16 AF 5B 14 5F C9 F5 79 C1 75 F9 3E 3B FB 0E ED 86 3D 06 CC FD B7 85 15"
|
||||
"00 00 00 48 36 73 3C 14 7D 6D 93 CB 00 00 00 01"
|
||||
"53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
|
||||
"4B 55 38 4F E2 59 C9 C8 4E 79 35 A0 03 CB E9 28")
|
||||
|
||||
;; Test Vector #5: Encrypting 32 octets using AES-CTR with 192-bit key
|
||||
(test-enc 5
|
||||
"7C 5C B2 40 1B 3D C3 3C 19 E7 34 08 19 E0 F6 9C 67 8C 3D B8 E6 F6 A9 1A"
|
||||
"00 96 B0 3B 02 0C 6E AD C2 CB 50 0D 00 00 00 01"
|
||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
|
||||
(string-append "45 32 43 FC 60 9B 23 32 7E DF AA FA 71 31 CD 9F"
|
||||
"84 90 70 1C 5A D4 A7 9C FC 1F E0 FF 42 F4 FB 00"))
|
||||
|
||||
;; Test Vector #6: Encrypting 36 octets using AES-CTR with 192-bit key
|
||||
(test-enc 6
|
||||
"02 BF 39 1E E8 EC B1 59 B9 59 61 7B 09 65 27 9B F5 9B 60 A7 86 D3 E0 FE"
|
||||
"00 07 BD FD 5C BD 60 27 8D CC 09 12 00 00 00 01"
|
||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
|
||||
"20 21 22 23")
|
||||
(string-append "96 89 3F C5 5E 5C 72 2F 54 0B 7D D1 DD F7 E7 58"
|
||||
"D2 88 BC 95 C6 91 65 88 45 36 C8 11 66 2F 21 88"
|
||||
"AB EE 09 35"))
|
||||
|
||||
;; Test Vector #7: Encrypting 16 octets using AES-CTR with 256-bit key
|
||||
(test-enc 7
|
||||
(string-append "77 6B EF F2 85 1D B0 6F 4C 8A 05 42 C8 69 6F 6C"
|
||||
"6A 81 AF 1E EC 96 B4 D3 7F C1 D6 89 E6 C1 C1 04")
|
||||
"00 00 00 60 DB 56 72 C9 7A A8 F0 B2 00 00 00 01"
|
||||
"53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
|
||||
"14 5A D0 1D BF 82 4E C7 56 08 63 DC 71 E3 E0 C0")
|
||||
|
||||
;; Test Vector #8: Encrypting 32 octets using AES-CTR with 256-bit key
|
||||
(test-enc 8
|
||||
(string-append "F6 D6 6D 6B D5 2D 59 BB 07 96 36 58 79 EF F8 86"
|
||||
"C6 6D D5 1A 5B 6A 99 74 4B 50 59 0C 87 A2 38 84")
|
||||
"00 FA AC 24 C1 58 5E F1 5A 43 D8 75 00 00 00 01"
|
||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
|
||||
(string-append "F0 5E 23 1B 38 94 61 2C 49 EE 00 0B 80 4E B2 A9"
|
||||
"B8 30 6B 50 8F 83 9D 6A 55 30 83 1D 93 44 AF 1C"))
|
||||
|
||||
;; Test Vector #9: Encrypting 36 octets using AES-CTR with 256-bit key
|
||||
(test-enc 9
|
||||
(string-append "FF 7A 61 7C E6 91 48 E4 F1 72 6E 2F 43 58 1D E2"
|
||||
"AA 62 D9 F8 05 53 2E DF F1 EE D6 87 FB 54 15 3D")
|
||||
"00 1C C5 B7 51 A5 1D 70 A1 C1 11 48 00 00 00 01"
|
||||
(string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
|
||||
"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
|
||||
"20 21 22 23")
|
||||
(string-append "EB 6C 52 82 1D 0B BB F7 CE 75 94 46 2A CA 4F AA"
|
||||
"B4 07 DF 86 65 69 FD 07 F4 8C C0 B5 83 D6 07 1F"
|
||||
"1E C0 E6 B8"))
|
|
@ -0,0 +1,42 @@
|
|||
#lang racket/base
|
||||
|
||||
(require rackunit)
|
||||
(require "asn1-ber.rkt")
|
||||
|
||||
(require (planet tonyg/bitsyntax))
|
||||
|
||||
(define dsa-key
|
||||
#"0\201\336\2@\v\336jE\275\310\266\313y\365\307\e\243\304p\b8l=\3419\227\262\340E\253\333\263%X<\0235\374\30b \367\244\306\253/\22\213b\27\333\203Q\376zS\1\fS\312[\2553\rj\252C-\2A\0\207\26gPqe\245\3632:\5\317\345w\373\v8\231g\3155\376\270\256\f\250c\271\253\2\276\32\365\246\f\265\243\220\36\0302\349\3wI\vZ$I\320\374f\235KX\37\361\235\333\335\236\326\301\2\25\0\215rI\353\212\275\360\222c\365\r\310Z~E\327\337\30\344e\2@.F\2726\24w\352\352%\213~O\2Y\352\246`\246\243\fi\3\v\262\311w\0\211\241.\35\20\377\207F\321\375\354\347\336z3*\241N\347CT\254W98\311'&\204E\277\220\241\343\23sG")
|
||||
|
||||
;; #"3081de02400bde6a45bdc8b6cb79f5c71ba3c47008386c3de13997b2e045abdbb325583c1335fc186220f7a4c6ab2f128b6217db8351fe7a53010c53ca5bad330d6aaa432d024100871667507165a5f3323a05cfe577fb0b389967cd35feb8ae0ca863b9ab02be1af5a60cb5a3901e18321c390377490b5a2449d0fc669d4b581ff19ddbdd9ed6c10215008d7249eb8abdf09263f50dc85a7e45d7df18e46502402e46ba361477eaea258b7e4f0259eaa660a6a30c69030bb2c9770089a12e1d10ff8746d1fdece7de7a332aa14ee74354ac573938c927268445bf90a1e3137347"
|
||||
|
||||
(define rsa-key
|
||||
#"0H\2A\0\257\247\361\314Jm\317w\325OD\223\263\353h\356\300\211Y\16x\344\361\314N\251\t\26\1S\362\222\205,ifN\374\321\230\355\363L\351\311M\255\335\301W\203\177;[\177\272\357\"p\nl\315\216\5\2\3\1\0\1")
|
||||
|
||||
;; #"3048024100afa7f1cc4a6dcf77d54f4493b3eb68eec089590e78e4f1cc4ea909160153f292852c69664efcd198edf34ce9c94dadddc157837f3b5b7fbaef22700a6ccd8e050203010001"
|
||||
|
||||
(check-equal? (bit-string (123 :: (t:long-ber-tag))) (bytes 123))
|
||||
(check-equal? (bit-string (234 :: (t:long-ber-tag))) (bytes 129 106))
|
||||
(check-equal? (bit-string (12345678 :: (t:long-ber-tag))) (bytes 133 241 194 78))
|
||||
|
||||
(check-equal? (bit-string-case (bytes 123) ([(v :: (t:long-ber-tag))] v)) 123)
|
||||
(check-equal? (bit-string-case (bytes 129 106) ([(v :: (t:long-ber-tag))] v)) 234)
|
||||
(check-equal? (bit-string-case (bytes 133 241 194 78) ([(v :: (t:long-ber-tag))] v)) 12345678)
|
||||
|
||||
(check-equal? (bit-string->bytes (bit-string (12 :: (t:ber-length-indicator))))
|
||||
(bytes 12))
|
||||
(check-equal? (bit-string->bytes (bit-string (123 :: (t:ber-length-indicator))))
|
||||
(bytes 123))
|
||||
(check-equal? (bit-string->bytes (bit-string (1234 :: (t:ber-length-indicator))))
|
||||
(bytes 130 4 210))
|
||||
(check-equal? (bit-string->bytes (bit-string (12345678 :: (t:ber-length-indicator))))
|
||||
(bytes 131 188 97 78))
|
||||
|
||||
(check-equal? (bit-string-case (bytes 12) ([(v :: (t:ber-length-indicator))] v)) 12)
|
||||
(check-equal? (bit-string-case (bytes 123) ([(v :: (t:ber-length-indicator))] v)) 123)
|
||||
(check-equal? (bit-string-case (bytes 130 4 210) ([(v :: (t:ber-length-indicator))] v)) 1234)
|
||||
(check-equal? (bit-string-case (bytes 131 188 97 78) ([(v :: (t:ber-length-indicator))] v))
|
||||
12345678)
|
||||
|
||||
(check-equal? (asn1-ber-encode (asn1-ber-decode-all dsa-key)) dsa-key)
|
||||
(check-equal? (asn1-ber-encode (asn1-ber-decode-all rsa-key)) rsa-key)
|
|
@ -0,0 +1,12 @@
|
|||
-----BEGIN DSA PRIVATE KEY-----
|
||||
MIIBuwIBAAKBgQCEQ1YvOR7/MQByCPJt/FSO7NN7YO1VLqy7A95M07q6AaG5FZ2A
|
||||
m9s8KZPlNFPrNhG8pRxxHhWgfBczoIObZi2saXeXQyTCUtHUejQBk+Xl31I+0SYU
|
||||
/m5fIP3Q9UY3cR8LucsIQkJIcuLVpoMmtFA/EtxYs+roxm+wtMlgk/8HkQIVAObN
|
||||
DEIjvgKwW9MKzRz8VXms/aDDAoGAeMnKQxj/iBSfQ3Wsd4ipCi3PdoLJ0+TJuiFG
|
||||
0tmbxLxwC0YCR24YMeobva/SpSu6y48+2rjv9Wc9ZKwISbrdO6xrNgDJtoCZLGK+
|
||||
C2DHEC3rBYFicOgpoysk/HsS/to3GtMnPyA2NJDR/cjUdgWBRg+4eAx1ZsVPjaJT
|
||||
A5Z60tECgYAkhzk5oi/b3zxPEPoFYki2apR4mciJso/1mYvb6fpd+rzlihNrkFAA
|
||||
LL+6uOofkyf32FIQhEN+JXDNMfaHreJkLPxGXIJ4FyUbrrZcxbmgJdh9NHd0L/mI
|
||||
yIHlo+SImp1DLCEtRP1GwKv8Lm0/rFNpY/z5Os3qeXKw1swDvEMfywIVANtH4mhn
|
||||
F6JfX/4/cJ4cpGlcgrWe
|
||||
-----END DSA PRIVATE KEY-----
|
Loading…
Reference in New Issue