commit f246f6cd15874727942008f37023466b7b3858f1 Author: Tony Garnock-Jones Date: Fri May 10 17:01:46 2013 -0400 Initial commit from racket-ssh diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..724bbe1 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +compiled/ diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..39cc1bc --- /dev/null +++ b/Makefile @@ -0,0 +1,5 @@ +all: + raco make new-server.rkt + +clean: + find . -name compiled -type d | xargs rm -rf diff --git a/TODO b/TODO new file mode 100644 index 0000000..65a9e43 --- /dev/null +++ b/TODO @@ -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 diff --git a/aes-ctr.rkt b/aes-ctr.rkt new file mode 100644 index 0000000..659b646 --- /dev/null +++ b/aes-ctr.rkt @@ -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) diff --git a/asn1-ber.rkt b/asn1-ber.rkt new file mode 100644 index 0000000..39714d2 --- /dev/null +++ b/asn1-ber.rkt @@ -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)))) diff --git a/cook-port.rkt b/cook-port.rkt new file mode 100644 index 0000000..fc3ca65 --- /dev/null +++ b/cook-port.rkt @@ -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) diff --git a/functional-queue.rkt b/functional-queue.rkt new file mode 100644 index 0000000..14334e1 --- /dev/null +++ b/functional-queue.rkt @@ -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)))))) diff --git a/mapping.rkt b/mapping.rkt new file mode 100644 index 0000000..9189f16 --- /dev/null +++ b/mapping.rkt @@ -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 ...)))) diff --git a/marketplace-support.rkt b/marketplace-support.rkt new file mode 100644 index 0000000..acd14af --- /dev/null +++ b/marketplace-support.rkt @@ -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)) diff --git a/new-server.rkt b/new-server.rkt new file mode 100644 index 0000000..9bc2443 --- /dev/null +++ b/new-server.rkt @@ -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) diff --git a/oakley-group-14.pem b/oakley-group-14.pem new file mode 100644 index 0000000..ac12435 --- /dev/null +++ b/oakley-group-14.pem @@ -0,0 +1,7 @@ +-----BEGIN DH PARAMETERS----- +MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO +NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr ++1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc +YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei +j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg== +-----END DH PARAMETERS----- diff --git a/oakley-group-2.pem b/oakley-group-2.pem new file mode 100644 index 0000000..bbfb1bf --- /dev/null +++ b/oakley-group-2.pem @@ -0,0 +1,5 @@ +-----BEGIN DH PARAMETERS----- +MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE +3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta +iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC +-----END DH PARAMETERS----- diff --git a/oakley-groups.rkt b/oakley-groups.rkt new file mode 100644 index 0000000..ed308a5 --- /dev/null +++ b/oakley-groups.rkt @@ -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=="))) diff --git a/sandboxes.rkt b/sandboxes.rkt new file mode 100644 index 0000000..9400565 --- /dev/null +++ b/sandboxes.rkt @@ -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))) diff --git a/ssh-channel.rkt b/ssh-channel.rkt new file mode 100644 index 0000000..d302ab1 --- /dev/null +++ b/ssh-channel.rkt @@ -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 + outbound-packet-size ;; Maybe + 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) diff --git a/ssh-exceptions.rkt b/ssh-exceptions.rkt new file mode 100644 index 0000000..43cb5ec --- /dev/null +++ b/ssh-exceptions.rkt @@ -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?)))) diff --git a/ssh-host-key.rkt b/ssh-host-key.rkt new file mode 100644 index 0000000..fd9a252 --- /dev/null +++ b/ssh-host-key.rkt @@ -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)) diff --git a/ssh-message-types.rkt b/ssh-message-types.rkt new file mode 100644 index 0000000..253a027 --- /dev/null +++ b/ssh-message-types.rkt @@ -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)) diff --git a/ssh-numbers.rkt b/ssh-numbers.rkt new file mode 100644 index 0000000..ca3666b --- /dev/null +++ b/ssh-numbers.rkt @@ -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] + )) diff --git a/ssh-session.rkt b/ssh-session.rkt new file mode 100644 index 0000000..3c076d5 --- /dev/null +++ b/ssh-session.rkt @@ -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 + 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 ]* -> 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 ]* -> 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 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 -> 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)]))) diff --git a/ssh-transport.rkt b/ssh-transport.rkt new file mode 100644 index 0000000..4f5dbf0 --- /dev/null +++ b/ssh-transport.rkt @@ -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 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)]))]))) diff --git a/test-aes-ctr.rkt b/test-aes-ctr.rkt new file mode 100644 index 0000000..90205a6 --- /dev/null +++ b/test-aes-ctr.rkt @@ -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^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")) diff --git a/test-asn1-ber.rkt b/test-asn1-ber.rkt new file mode 100644 index 0000000..a5abf44 --- /dev/null +++ b/test-asn1-ber.rkt @@ -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) diff --git a/test-dsa-key b/test-dsa-key new file mode 100644 index 0000000..94350ee --- /dev/null +++ b/test-dsa-key @@ -0,0 +1,12 @@ +-----BEGIN DSA PRIVATE KEY----- +MIIBuwIBAAKBgQCEQ1YvOR7/MQByCPJt/FSO7NN7YO1VLqy7A95M07q6AaG5FZ2A +m9s8KZPlNFPrNhG8pRxxHhWgfBczoIObZi2saXeXQyTCUtHUejQBk+Xl31I+0SYU +/m5fIP3Q9UY3cR8LucsIQkJIcuLVpoMmtFA/EtxYs+roxm+wtMlgk/8HkQIVAObN +DEIjvgKwW9MKzRz8VXms/aDDAoGAeMnKQxj/iBSfQ3Wsd4ipCi3PdoLJ0+TJuiFG +0tmbxLxwC0YCR24YMeobva/SpSu6y48+2rjv9Wc9ZKwISbrdO6xrNgDJtoCZLGK+ +C2DHEC3rBYFicOgpoysk/HsS/to3GtMnPyA2NJDR/cjUdgWBRg+4eAx1ZsVPjaJT +A5Z60tECgYAkhzk5oi/b3zxPEPoFYki2apR4mciJso/1mYvb6fpd+rzlihNrkFAA +LL+6uOofkyf32FIQhEN+JXDNMfaHreJkLPxGXIJ4FyUbrrZcxbmgJdh9NHd0L/mI +yIHlo+SImp1DLCEtRP1GwKv8Lm0/rFNpY/z5Os3qeXKw1swDvEMfywIVANtH4mhn +F6JfX/4/cJ4cpGlcgrWe +-----END DSA PRIVATE KEY-----