Initial commit from racket-ssh

This commit is contained in:
Tony Garnock-Jones 2013-05-10 17:01:46 -04:00
commit f246f6cd15
24 changed files with 3472 additions and 0 deletions

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
compiled/

5
Makefile Normal file
View File

@ -0,0 +1,5 @@
all:
raco make new-server.rkt
clean:
find . -name compiled -type d | xargs rm -rf

16
TODO Normal file
View File

@ -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

64
aes-ctr.rkt Normal file
View File

@ -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)

164
asn1-ber.rkt Normal file
View File

@ -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))))

95
cook-port.rkt Normal file
View File

@ -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)

75
functional-queue.rkt Normal file
View File

@ -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))))))

35
mapping.rkt Normal file
View File

@ -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 ...))))

12
marketplace-support.rkt Normal file
View File

@ -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))

284
new-server.rkt Normal file
View File

@ -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)

7
oakley-group-14.pem Normal file
View File

@ -0,0 +1,7 @@
-----BEGIN DH PARAMETERS-----
MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO
NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr
+1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc
YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei
j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==
-----END DH PARAMETERS-----

5
oakley-group-2.pem Normal file
View File

@ -0,0 +1,5 @@
-----BEGIN DH PARAMETERS-----
MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE
3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta
iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC
-----END DH PARAMETERS-----

28
oakley-groups.rkt Normal file
View File

@ -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==")))

43
sandboxes.rkt Normal file
View File

@ -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)))

115
ssh-channel.rkt Normal file
View File

@ -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)

41
ssh-exceptions.rkt Normal file
View File

@ -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?))))

211
ssh-host-key.rkt Normal file
View File

@ -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))

345
ssh-message-types.rkt Normal file
View File

@ -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))

378
ssh-numbers.rkt Normal file
View File

@ -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]
))

904
ssh-session.rkt Normal file
View File

@ -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)])))

454
ssh-transport.rkt Normal file
View File

@ -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)]))])))

136
test-aes-ctr.rkt Normal file
View File

@ -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"))

42
test-asn1-ber.rkt Normal file
View File

@ -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)

12
test-dsa-key Normal file
View File

@ -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-----