Browse Source

Initial commit from racket-ssh

main
Tony Garnock-Jones 8 years ago
commit
f246f6cd15
  1. 1
      .gitignore
  2. 5
      Makefile
  3. 16
      TODO
  4. 64
      aes-ctr.rkt
  5. 164
      asn1-ber.rkt
  6. 95
      cook-port.rkt
  7. 75
      functional-queue.rkt
  8. 35
      mapping.rkt
  9. 12
      marketplace-support.rkt
  10. 284
      new-server.rkt
  11. 7
      oakley-group-14.pem
  12. 5
      oakley-group-2.pem
  13. 28
      oakley-groups.rkt
  14. 43
      sandboxes.rkt
  15. 115
      ssh-channel.rkt
  16. 41
      ssh-exceptions.rkt
  17. 211
      ssh-host-key.rkt
  18. 345
      ssh-message-types.rkt
  19. 378
      ssh-numbers.rkt
  20. 904
      ssh-session.rkt
  21. 454
      ssh-transport.rkt
  22. 136
      test-aes-ctr.rkt
  23. 42
      test-asn1-ber.rkt
  24. 12
      test-dsa-key

1
.gitignore

@ -0,0 +1 @@
compiled/

5
Makefile

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

16
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

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

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

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

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

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

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

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

7
oakley-group-14.pem

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

5
oakley-group-2.pem

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

28
oakley-groups.rkt

@ -0,0 +1,28 @@
#lang racket/base
;; Construct Oakley MODP Diffie-Hellman groups from RFCs 2409 and 3526.
(provide dh:oakley-group-2
dh:oakley-group-14)
;;(require (planet vyzo/crypto))
(require (planet vyzo/crypto/dh))
(require (only-in net/base64 base64-decode))
(define dh:oakley-group-2
(make-!dh
1024
(base64-decode
#"MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE
3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta
iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC")))
(define dh:oakley-group-14
(make-!dh
2048
(base64-decode
#"MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO
NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr
+1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc
YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei
j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==")))

43
sandboxes.rkt

@ -0,0 +1,43 @@
#lang racket/base
;; Sandbox management and use.
(require racket/match)
(require racket/sandbox)
(provide repl-shell)
(struct user-state (name master-sandbox master-namespace) #:transparent)
(define *user-states* (make-hash))
(define (get-user-state username)
(when (not (hash-has-key? *user-states* username))
(let* ((sb (make-evaluator 'racket/base))
(ns (call-in-sandbox-context sb current-namespace)))
(hash-set! *user-states* username
(user-state username
sb
ns))))
(hash-ref *user-states* username))
(define (repl-shell username in out)
(match-define (user-state _ master-sandbox master-namespace) (get-user-state username))
(parameterize ((current-input-port in)
(current-output-port out)
(current-error-port out)
(sandbox-input in)
(sandbox-output out)
(sandbox-error-output out)
(sandbox-memory-limit 2) ;; megabytes
(sandbox-eval-limits #f)
(sandbox-namespace-specs (list (lambda () master-namespace))))
(printf "Hello, ~a.\n" username)
(define slave-sandbox (make-evaluator '(begin)))
;; ^^ uses master-namespace via sandbox-namespace-specs
(parameterize ((current-namespace master-namespace)
(current-eval slave-sandbox))
(read-eval-print-loop))
(fprintf out "\nGoodbye!\n")
(kill-evaluator slave-sandbox)
(close-input-port in)
(close-output-port out)))

115
ssh-channel.rkt

@ -0,0 +1,115 @@
#lang racket/base
(require racket/set)
(require racket/match)
(provide (struct-out ssh-channel)
(struct-out channel-name)
(struct-out channel-stream-name)
(struct-out channel-message)
(struct-out channel-stream-credit)
(struct-out channel-stream-data)
(struct-out channel-stream-extended-data)
(struct-out channel-stream-eof)
(struct-out channel-stream-notify)
(struct-out channel-stream-request)
(struct-out channel-stream-ok)
(struct-out channel-stream-fail)
(struct-out channel-stream-config)
(struct-out channel-stream-open-failure))
;; A CloseState is one of
;; - 'neither, indicating that neither side has signalled closure
;; - 'local, only the local end has signalled closure
;; - 'remote, only the remote end has signalled closure
;; - 'both, both ends have signalled closure.
;; Represents local knowledge of the state of a shared shutdown state
;; machine.
;;
;; 'neither
;; / \
;; \/ \/
;; 'local 'remote
;; \ /
;; \/ \/
;; 'both
;; TODO: Once the presence-based routing table can be queried, the
;; CloseState becomes redundant, because we can just ask which roles
;; remain to decide whether either direction is still open.
;; A ChannelState is a (ssh-channel ...) TODO
;; Named ssh-channel to avoid conflicts with Racket's built-in
;; synchronous channels.
(struct ssh-channel (name ;; ChannelName
local-ref ;; Uint32
remote-ref ;; Maybe<Uint32>
outbound-packet-size ;; Maybe<Natural>
close-state ;; CloseState covering CLOSE signals
)
#:transparent)
;; ChannelName = (channel-name Boolean Bytes Any)
;; Names a channel within a connection. Unique within a particular
;; connection. If (locally-originated?) is true, then the local peer
;; is the one that opened this channel, and the local peer is
;; reponsible for choosing the (identifier) and ensuring that it is
;; unique with respect to other locally-originated streams within this
;; connection; if false, the remote peer opened the channel, and the
;; (identifier) is chosen managed by the connection-control code. If
;; (locally-originated?) is true, the (type) is chosen by the local
;; peer, otherwise it is chosen by the remote peer.
(struct channel-name (locally-originated? type identifier) #:prefab)
;; ChannelStreamName = (channel-stream-name Boolean ChannelName)
;; Names a stream within a channel within a connection. If (inbound?)
;; is true, this is the stream of packets from the remote peer to the
;; local peer; if false, the reverse.
(struct channel-stream-name (inbound? channel) #:prefab)
;; ChannelMessage = (channel-message ChannelStreamName ChannelMessageBody)
;; Relates a message to a particular stream within a channel within a
;; connection.
(struct channel-message (stream-name body) #:prefab)
;; A ChannelMessageBody is one of
;; -- (channel-stream-credit NonNegativeInteger) **
;; Informs the publisher that it may transmit another (count)
;; bytes.
;; -- (channel-stream-data Bytes)
;; Data intended for the subscriber.
;; -- (channel-stream-extended-data Uint32 Bytes)
;; Extended data intended for the subscriber. The type code is one
;; of those defined in ssh-numbers.rkt; for example,
;; SSH_EXTENDED_DATA_STDERR.
;; -- (channel-stream-eof)
;; Signals the end of the data stream. Notice that channel closure
;; is signalled with presence changes.
;; -- (channel-stream-notify Bytes Bytes)
;; One-way notification of SSH_MSG_CHANNEL_REQUEST.
;; -- (channel-stream-request Bytes Bytes)
;; RPC SSH_MSG_CHANNEL_REQUEST request.
;; -- (channel-stream-ok) **
;; RPC SSH_MSG_CHANNEL_REQUEST reply.
;; -- (channel-stream-fail) **
;; RPC SSH_MSG_CHANNEL_REQUEST error.
;; -- (channel-stream-config Uint32 Bytes) **
;; Either SSH_MSG_CHANNEL_OPEN or
;; SSH_MSG_CHANNEL_OPEN_CONFIRMATION, depending on direction of
;; travel. Must be sent before any channel-stream-credit messages.
;; -- (channel-stream-open-failure Uint32 Bytes)
;; SSH_MSG_CHANNEL_OPEN_FAILURE.
;;
;; Messages marked ** travel "upstream", from subscriber to publisher.
(struct channel-stream-credit (count) #:prefab)
(struct channel-stream-data (bytes) #:prefab)
(struct channel-stream-extended-data (type bytes) #:prefab)
(struct channel-stream-eof () #:prefab)
(struct channel-stream-notify (type bytes) #:prefab)
(struct channel-stream-request (type bytes) #:prefab)
(struct channel-stream-ok () #:prefab)
(struct channel-stream-fail () #:prefab)
(struct channel-stream-config (maximum-packet-size extra-data) #:prefab)
(struct channel-stream-open-failure (reason description) #:prefab)

41
ssh-exceptions.rkt

@ -0,0 +1,41 @@
#lang racket/base
;; Exceptions and error-raising and -handling utilities used in structuring SSH sessions.
(provide (struct-out exn:fail:contract:protocol)
disconnect-with-error
disconnect-with-error/local-info
disconnect-with-error*)
;; An exn:fail:contract:protocol, when thrown by the transport (TODO:
;; clarify scope of this behaviour) will cause a SSH_MSG_DISCONNECT to
;; be sent to the remote party with the included reason code, using
;; the exn-message as the description. The local-info field is useful
;; information for diagnosing problems known to the local stack that
;; should not be transmitted to the remote party. For example, upon
;; detection of a MAC failure, it might be useful to know the expected
;; and actual MACs for debugging, but they should not be sent over the
;; wire because we could be experiencing some kind of attack.
(struct exn:fail:contract:protocol exn:fail:contract
(reason-code local-info originated-at-peer?)
#:transparent)
;; Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
(define (disconnect-with-error reason-code format-string . args)
(apply disconnect-with-error* #f '() reason-code format-string args))
;; Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
(define (disconnect-with-error/local-info local-info reason-code format-string . args)
(apply disconnect-with-error* #f local-info reason-code format-string args))
;; Boolean Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
(define (disconnect-with-error* originated-at-peer?
local-info
reason-code
format-string
. args)
(let ((message (apply format format-string args)))
(raise (exn:fail:contract:protocol message
(current-continuation-marks)
reason-code
local-info
originated-at-peer?))))

211
ssh-host-key.rkt

@ -0,0 +1,211 @@
#lang racket/base
(require racket/match)
(require racket/port)
(require net/base64)
(require (planet vyzo/crypto))
(require (planet tonyg/bitsyntax))
(require "asn1-ber.rkt")
(require "ssh-message-types.rkt")
(require rackunit)
(provide (struct-out rsa-private-key)
(struct-out dsa-private-key)
(struct-out rsa-public-key)
(struct-out dsa-public-key)
public-key->pieces
pieces->public-key
host-key-algorithm->keys
host-key-algorithm->digest-type
host-key-signature
verify-host-key-signature!
pieces->ssh-host-key
ssh-host-key->pieces)
(struct rsa-private-key (version n e d p q dmp1 dmq1 iqmp) #:transparent)
(struct dsa-private-key (version p q g y x) #:transparent)
(struct rsa-public-key (n e) #:transparent)
(struct dsa-public-key (y p q g) #:transparent)
;; ASN.1 BER integers are signed.
(define (bs->n bs) (bit-string->integer bs #t #t))
(define (n->bs n) (integer->bit-string n (* 8 (mpint-width n)) #t))
(define (private-key->pieces key)
(bytes->private-key-pieces (private-key->bytes key)))
(define (bytes->private-key-pieces bs)
(match (asn1-ber-decode-all bs)
(`(0 16 ((0 2 ,version-bytes)
(0 2 ,n-bytes)
(0 2 ,e-bytes)
(0 2 ,d-bytes)
(0 2 ,p-bytes)
(0 2 ,q-bytes)
(0 2 ,dmp1-bytes)
(0 2 ,dmq1-bytes)
(0 2 ,iqmp-bytes)))
(rsa-private-key (bs->n version-bytes)
(bs->n n-bytes)
(bs->n e-bytes)
(bs->n d-bytes)
(bs->n p-bytes)
(bs->n q-bytes)
(bs->n dmp1-bytes)
(bs->n dmq1-bytes)
(bs->n iqmp-bytes)))
(`(0 16 ((0 2 ,version-bytes)
(0 2 ,p-bytes)
(0 2 ,q-bytes)
(0 2 ,g-bytes)
(0 2 ,public-key-bytes) ;; y
(0 2 ,private-key-bytes))) ;; x
(dsa-private-key (bs->n version-bytes)
(bs->n p-bytes)
(bs->n q-bytes)
(bs->n g-bytes)
(bs->n public-key-bytes)
(bs->n private-key-bytes)))))
(define (pieces->private-key p)
(match p
((struct rsa-private-key (version n e d p q dmp1 dmq1 iqmp))
(bytes->private-key pkey:rsa
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs version))
(0 2 ,(n->bs n))
(0 2 ,(n->bs e))
(0 2 ,(n->bs d))
(0 2 ,(n->bs p))
(0 2 ,(n->bs q))
(0 2 ,(n->bs dmp1))
(0 2 ,(n->bs dmq1))
(0 2 ,(n->bs iqmp)))))))
((struct dsa-private-key (version p q g y x))
(bytes->private-key pkey:dsa
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs version))
(0 2 ,(n->bs p))
(0 2 ,(n->bs q))
(0 2 ,(n->bs g))
(0 2 ,(n->bs y))
(0 2 ,(n->bs x)))))))))
(define (public-key->pieces key)
(match (asn1-ber-decode-all (public-key->bytes key))
(`(0 16 ((0 2 ,n-bytes)
(0 2 ,e-bytes)))
(rsa-public-key (bs->n n-bytes)
(bs->n e-bytes)))
(`(0 16 ((0 2 ,public-key-bytes) ;; y
(0 2 ,p-bytes)
(0 2 ,q-bytes)
(0 2 ,g-bytes)))
(dsa-public-key (bs->n public-key-bytes)
(bs->n p-bytes)
(bs->n q-bytes)
(bs->n g-bytes)))))
(define (pieces->public-key p)
(match p
((struct rsa-public-key (n e))
(bytes->public-key pkey:rsa
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs n))
(0 2 ,(n->bs e)))))))
((struct dsa-public-key (y p q g))
(bytes->public-key pkey:dsa
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs y))
(0 2 ,(n->bs p))
(0 2 ,(n->bs q))
(0 2 ,(n->bs g)))))))))
(define (host-key-algorithm->keys host-key-alg)
(case host-key-alg
((ssh-dss) (values host-key-dsa-private host-key-dsa-public))
(else (error 'host-key-algorithm->keys "Unsupported host-key-alg ~v" host-key-alg))))
(define (host-key-algorithm->digest-type host-key-alg)
(case host-key-alg
((ssh-rsa) digest:sha1)
((ssh-dss) digest:dss1)
(else (error 'host-key-algorithm->digest-type "Unsupported host-key-alg ~v" host-key-alg))))
(define (host-key-signature private-key host-key-alg exchange-hash)
(case host-key-alg
((ssh-rsa)
;; TODO: offer ssh-rsa. See comment in definition of
;; local-algorithm-list in ssh-transport.rkt.
(error 'host-key-signature "ssh-rsa host key signatures unimplemented"))
((ssh-dss)
(match (asn1-ber-decode-all (sign private-key digest:dss1 exchange-hash))
(`(0 16 ((0 2 ,r-bytes)
(0 2 ,s-bytes)))
(bit-string (#"ssh-dss" :: (t:string))
((bit-string ((bs->n r-bytes) :: big-endian integer bits 160)
((bs->n s-bytes) :: big-endian integer bits 160))
:: (t:string))))))))
(define (verify-host-key-signature! public-key host-key-alg exchange-hash h-signature)
;; TODO: If we are *re*keying, worth checking here that the key hasn't *changed* either.
(write `(TODO check-host-key!)) (newline) (flush-output) ;; actually check the identity TOFU/POP
(case host-key-alg
((ssh-rsa)
;; TODO: offer ssh-rsa. See comment in definition of
;; local-algorithm-list in ssh-transport.rkt.
(error 'verify-host-key-signature! "ssh-rsa host key signatures unimplemented"))
((ssh-dss)
(define signature (bit-string-case h-signature
([ (= #"ssh-dss" :: (t:string #:pack))
(r-and-s :: (t:string)) ]
(bit-string-case r-and-s
([ (r :: big-endian integer bits 160)
(s :: big-endian integer bits 160) ]
(asn1-ber-encode `(0 16 ((0 2 ,(n->bs r))
(0 2 ,(n->bs s))))))))))
(when (not (verify public-key digest:dss1 signature exchange-hash))
(error 'verify-host-key-signature! "Signature mismatch")))))
(define (pieces->ssh-host-key pieces)
(match pieces
((struct rsa-public-key (n e))
(bit-string (#"ssh-rsa" :: (t:string))
(e :: (t:mpint))
(n :: (t:mpint))))
((struct dsa-public-key (y p q g))
(bit-string (#"ssh-dss" :: (t:string))
(p :: (t:mpint))
(q :: (t:mpint))
(g :: (t:mpint))
(y :: (t:mpint))))))
(define (ssh-host-key->pieces blob)
(bit-string-case blob
([ (= #"ssh-rsa" :: (t:string #:pack))
(e :: (t:mpint))
(n :: (t:mpint)) ]
(rsa-public-key n e))
([ (= #"ssh-dss" :: (t:string #:pack))
(p :: (t:mpint))
(q :: (t:mpint))
(g :: (t:mpint))
(y :: (t:mpint)) ]
(dsa-public-key y p q g))))
;; TODO: proper store for keys
(define (load-private-key filename)
(pieces->private-key
(bytes->private-key-pieces
(base64-decode
(regexp-replace* #rx"(?m:^-.*-$)"
(call-with-input-file filename port->bytes)
#"")))))
(define host-key-dsa-private (load-private-key "test-dsa-key"))
(define host-key-dsa-public (pkey->public-key host-key-dsa-private))
(check-equal? (public-key->bytes (pieces->public-key (public-key->pieces host-key-dsa-public)))
(public-key->bytes host-key-dsa-private))

345
ssh-message-types.rkt

@ -0,0 +1,345 @@
#lang racket/base
(require "ssh-numbers.rkt")
(require (for-syntax racket/base))
(require (for-syntax (only-in racket/list append*)))
(require (for-syntax (only-in srfi/1 iota)))
(require (planet tonyg/bitsyntax))
(require racket/bytes)
(require rackunit)
(provide ssh-message-decode
ssh-message-encode)
(provide t:boolean
t:string
t:mpint
mpint-width
t:name-list)
(provide (struct-out ssh-msg-kexinit)
(struct-out ssh-msg-kexdh-init)
(struct-out ssh-msg-kexdh-reply)
(struct-out ssh-msg-disconnect)
(struct-out ssh-msg-unimplemented)
(struct-out ssh-msg-newkeys)
(struct-out ssh-msg-debug)
(struct-out ssh-msg-ignore)
(struct-out ssh-msg-service-request)
(struct-out ssh-msg-service-accept)
(struct-out ssh-msg-userauth-request)
(struct-out ssh-msg-userauth-failure)
(struct-out ssh-msg-userauth-success)
(struct-out ssh-msg-global-request)
(struct-out ssh-msg-request-success)
(struct-out ssh-msg-request-failure)
(struct-out ssh-msg-channel-open)
(struct-out ssh-msg-channel-open-confirmation)
(struct-out ssh-msg-channel-open-failure)
(struct-out ssh-msg-channel-window-adjust)
(struct-out ssh-msg-channel-data)
(struct-out ssh-msg-channel-extended-data)
(struct-out ssh-msg-channel-eof)
(struct-out ssh-msg-channel-close)
(struct-out ssh-msg-channel-request)
(struct-out ssh-msg-channel-success)
(struct-out ssh-msg-channel-failure)
)
(define encoder-map (make-hasheqv))
(define decoder-map (make-hasheqv))
(define (ssh-message-decode packet)
(define type-code (bytes-ref packet 0))
(define decoder (hash-ref decoder-map type-code #f))
(if decoder
(decoder packet)
#f))
(define (ssh-message-encode m)
(bit-string->bytes ((hash-ref encoder-map (prefab-struct-key m)) m)))
(define-syntax define-ssh-message-type
(syntax-rules ()
((_ name type-byte-value (field-type field-name) ...)
(begin
(struct name (field-name ...) #:prefab)
(hash-set! encoder-map 'name
(compute-ssh-message-encoder type-byte-value field-type ...))
(hash-set! decoder-map type-byte-value
(compute-ssh-message-decoder name type-byte-value field-type ...))))))
(define-syntax t:boolean
(syntax-rules ()
((_ #t input ks kf)
(bit-string-case input
([ v (rest :: binary) ]
(ks (not (zero? v)) rest))
(else (kf))))
((_ #f v) (bit-string (if v 1 0)))))
(define-syntax t:packed-bytes
(syntax-rules ()
((_ #t input ks kf n)
(bit-string-case input
([ (bs :: binary bytes n) (rest :: binary) ]
(ks (bit-string->bytes bs) rest))
(else (kf))))
((_ #t input ks kf)
(bit-string-case input
([ (rest :: binary) ]
(ks (bit-string->bytes rest) #""))
(else (kf))))
((_ #f bs n) (bit-string (bs :: binary)))
((_ #f bs) (bit-string (bs :: binary)))))
(define-syntax t:string
(syntax-rules ()
((_ #t input ks kf #:pack)
(t:string #t input (lambda (v rest) (ks (bit-string->bytes v) rest)) kf))
((_ #t input ks kf)
(bit-string-case input
([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
(ks body rest))
(else (kf))))
((_ #f bs #:pack) (t:string #f bs)) ;; #:pack ignored on encoding
((_ #f bs)
(bit-string ((bytes-length (bit-string->bytes bs)) :: integer bits 32)
(bs :: binary)))))
(define-syntax t:mpint
(syntax-rules ()
((_ #t input ks kf)
(bit-string-case input
([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
(ks (if (zero? (bit-string-length body)) 0 (bit-string->integer body #t #t))
rest))
(else (kf))))
((_ #f n)
(let* ((width (mpint-width n))
(buf (integer->bit-string n (* 8 width) #t)))
(bit-string (width :: integer bits 32) (buf :: binary))))))
(define-syntax t:name-list
(syntax-rules ()
((_ #t input ks kf)
(t:string #t
input
(lambda (body rest) (ks (name-list->symbols body) rest))
kf))
((_ #f ns)
(t:string #f (symbols->name-list ns)))))
(define-for-syntax (codec-options field-type)
(syntax-case field-type (byte boolean uint32 uint64 string mpint name-list)
(byte #'(integer bits 8))
((byte n) #'((t:packed-bytes n)))
(boolean #'((t:boolean)))
(uint32 #'(integer bits 32))
(uint64 #'(integer bits 64))
(string #'((t:string #:pack)))
(mpint #'((t:mpint)))
(name-list #'((t:name-list)))
(extension #'((t:packed-bytes)))))
(define-syntax compute-ssh-message-encoder
(lambda (stx)
(syntax-case stx ()
((_ type-byte-value field-type ...)
#`(lambda (message)
(let ((vec (struct->vector message)))
#,(with-syntax (((field-spec ...)
(let ((type-list (syntax->list #'(field-type ...))))
(map (lambda (index type)
#`((vector-ref vec #,index) :: #,@(codec-options type)))
(iota (length type-list) 1)
type-list))))
#'(bit-string (type-byte-value :: integer bytes 1)
field-spec ...))))))))
(define-syntax compute-ssh-message-decoder
(lambda (stx)
(syntax-case stx ()
((_ struct-name type-byte-value field-type ...)
(with-syntax (((temp-name ...) (generate-temporaries #'(field-type ...)))
(((codec-option ...) ...)
(map codec-options (syntax->list #'(field-type ...)))))
#`(lambda (packet)
(bit-string-case packet
([ (= type-byte-value) (temp-name :: codec-option ...) ... ]
(struct-name temp-name ...)))))))))
(define (mpint-width n)
(if (zero? n)
0
(+ 1 (quotient (integer-length n) 8))))
(check-eqv? (mpint-width 0) 0)
(check-eqv? (mpint-width #x9a378f9b2e332a7) 8)
(check-eqv? (mpint-width #x7f) 1)
(check-eqv? (mpint-width #x80) 2)
(check-eqv? (mpint-width #x81) 2)
(check-eqv? (mpint-width #xff) 2)
(check-eqv? (mpint-width #x100) 2)
(check-eqv? (mpint-width #x101) 2)
(check-eqv? (mpint-width #x-1234) 2)
(check-eqv? (mpint-width #x-deadbeef) 5)
(define (symbols->name-list syms)
(bytes-join (map (lambda (s) (string->bytes/utf-8 (symbol->string s))) syms) #","))
(define (name-list->symbols bs)
(if (zero? (bit-string-length bs))
'()
(map string->symbol (regexp-split #rx"," (bytes->string/utf-8 (bit-string->bytes bs))))))
(struct test-message (value) #:prefab)
(let ((test-decode (compute-ssh-message-decoder test-message 123 mpint))
(test-encode (compute-ssh-message-encoder 123 mpint)))
(define (bidi-check msg enc-without-type-tag)
(let ((enc (bytes-append (bytes 123) enc-without-type-tag)))
(let ((msg-enc (bit-string->bytes (test-encode msg)))
(enc-msg (test-decode enc)))
(if (and (equal? msg-enc enc)
(equal? enc-msg msg))
'ok
`(fail ,msg-enc ,enc-msg)))))
(check-eqv? (bidi-check (test-message 0) (bytes 0 0 0 0)) 'ok)
(check-eqv? (bidi-check (test-message #x9a378f9b2e332a7)
(bytes #x00 #x00 #x00 #x08
#x09 #xa3 #x78 #xf9
#xb2 #xe3 #x32 #xa7)) 'ok)
(check-eqv? (bidi-check (test-message #x80)
(bytes #x00 #x00 #x00 #x02 #x00 #x80)) 'ok)
(check-eqv? (bidi-check (test-message #x-1234)
(bytes #x00 #x00 #x00 #x02 #xed #xcc)) 'ok)
(check-eqv? (bidi-check (test-message #x-deadbeef)
(bytes #x00 #x00 #x00 #x05
#xff #x21 #x52 #x41 #x11)) 'ok))
(define-ssh-message-type ssh-msg-kexinit SSH_MSG_KEXINIT
((byte 16) cookie)
(name-list kex_algorithms)
(name-list server_host_key_algorithms)
(name-list encryption_algorithms_client_to_server)
(name-list encryption_algorithms_server_to_client)
(name-list mac_algorithms_client_to_server)
(name-list mac_algorithms_server_to_client)
(name-list compression_algorithms_client_to_server)
(name-list compression_algorithms_server_to_client)
(name-list languages_client_to_server)
(name-list languages_server_to_client)
(boolean first_kex_packet_follows)
(uint32 reserved))
(define-ssh-message-type ssh-msg-kexdh-init SSH_MSG_KEXDH_INIT
(mpint e))
(define-ssh-message-type ssh-msg-kexdh-reply SSH_MSG_KEXDH_REPLY
(string host-key)
(mpint f)
(string h-signature))
(define-ssh-message-type ssh-msg-disconnect SSH_MSG_DISCONNECT
(uint32 reason-code)
(string description)
;; TODO: OpenSSH 5.3p1 Debian-3ubuntu7 25 Mar 2009 (from lucid)
;; sends SSH_MSG_DISCONNECT without the language-tag field! In
;; particular, when I press ^D to terminate my session, I get
;; #"\1\0\0\0\v\0\0\0\24disconnected by user".
(string language-tag))
(define-ssh-message-type ssh-msg-unimplemented SSH_MSG_UNIMPLEMENTED
(uint32 sequence-number))
(define-ssh-message-type ssh-msg-newkeys SSH_MSG_NEWKEYS)
(define-ssh-message-type ssh-msg-debug SSH_MSG_DEBUG
(boolean always-display?)
(string message)
(string language-tag))
(define-ssh-message-type ssh-msg-ignore SSH_MSG_IGNORE
(string data))
(define-ssh-message-type ssh-msg-service-request SSH_MSG_SERVICE_REQUEST
(string service-name))
(define-ssh-message-type ssh-msg-service-accept SSH_MSG_SERVICE_ACCEPT
(string service-name))
(define-ssh-message-type ssh-msg-userauth-request SSH_MSG_USERAUTH_REQUEST
(string user-name)
(string service-name)
(string method-name)
(extension method-specific-fields))
(define-ssh-message-type ssh-msg-userauth-failure SSH_MSG_USERAUTH_FAILURE
(name-list continuable-authentications)
(boolean partial-success?))
(define-ssh-message-type ssh-msg-userauth-success SSH_MSG_USERAUTH_SUCCESS)
(define-ssh-message-type ssh-msg-global-request SSH_MSG_GLOBAL_REQUEST
(string request-name)
(boolean want-reply?)
(extension data))
(define-ssh-message-type ssh-msg-request-success SSH_MSG_REQUEST_SUCCESS
(extension data))
(define-ssh-message-type ssh-msg-request-failure SSH_MSG_REQUEST_FAILURE)
(define-ssh-message-type ssh-msg-channel-open SSH_MSG_CHANNEL_OPEN
(string channel-type)
(uint32 sender-channel)
(uint32 initial-window-size)
(uint32 maximum-packet-size)
(extension data))
(define-ssh-message-type ssh-msg-channel-open-confirmation SSH_MSG_CHANNEL_OPEN_CONFIRMATION
(uint32 recipient-channel)
(uint32 sender-channel)
(uint32 initial-window-size)
(uint32 maximum-packet-size)
(extension data))
(define-ssh-message-type ssh-msg-channel-open-failure SSH_MSG_CHANNEL_OPEN_FAILURE
(uint32 recipient-channel)
(uint32 reason)
(string description)
(string language))
(define-ssh-message-type ssh-msg-channel-window-adjust SSH_MSG_CHANNEL_WINDOW_ADJUST
(uint32 recipient-channel)
(uint32 bytes))
(define-ssh-message-type ssh-msg-channel-data SSH_MSG_CHANNEL_DATA
(uint32 recipient-channel)
(string data))
(define-ssh-message-type ssh-msg-channel-extended-data SSH_MSG_CHANNEL_EXTENDED_DATA
(uint32 recipient-channel)
(uint32 type-code)
(string data))
(define-ssh-message-type ssh-msg-channel-eof SSH_MSG_CHANNEL_EOF
(uint32 recipient-channel))
(define-ssh-message-type ssh-msg-channel-close SSH_MSG_CHANNEL_CLOSE
(uint32 recipient-channel))
(define-ssh-message-type ssh-msg-channel-request SSH_MSG_CHANNEL_REQUEST
(uint32 recipient-channel)
(string type)
(boolean want-reply?)
(extension data))
(define-ssh-message-type ssh-msg-channel-success SSH_MSG_CHANNEL_SUCCESS
(uint32 recipient-channel))
(define-ssh-message-type ssh-msg-channel-failure SSH_MSG_CHANNEL_FAILURE
(uint32 recipient-channel))

378