Convert to extrasugar

This commit is contained in:
Tony Garnock-Jones 2013-06-10 18:04:15 -04:00
parent 8c4c95f1a6
commit 024b6b75cc
3 changed files with 343 additions and 328 deletions

View File

@ -38,14 +38,13 @@
(ground-vm (timer-driver) (ground-vm (timer-driver)
(tcp-driver) (tcp-driver)
(tcp-spy) (tcp-spy)
(spawn #:debug-name 'ssh-tcp-listener #:child listener))) (name-process 'ssh-tcp-listener (spawn listener))))
(define listener (define listener
(transition/no-state (transition/no-state
(endpoint #:subscriber (tcp-channel ? (tcp-listener 2322) ?) (observe-publishers (tcp-channel ? (tcp-listener 2322) ?)
#:observer (match-conversation r
#:conversation r (on-presence (session-vm r))))))
#:on-presence (session-vm r))))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
@ -67,24 +66,27 @@
(flush-output) (flush-output)
(void)) (void))
(list (list
(endpoint #:subscriber (wild) #:everything (observe-publishers/everything (wild)
#:role r (match-interest-type i
#:on-presence (dump 'arrived r) (match-conversation c
#:on-absence (dump 'departed r) (on-presence (dump 'arrived (role 'publisher c i)))
[message (dump 'message message)]) (on-absence (dump 'departed (role 'publisher c i)))
(endpoint #:publisher (wild) #:everything (on-message [message (dump 'message message)]))))
#:role r (observe-subscribers/everything (wild)
#:on-presence (dump 'arrived r) (match-interest-type i
#:on-absence (dump 'departed r) (match-conversation c
[message (dump 'message message)]))) (on-presence (dump 'arrived (role 'subscriber c i)))
(on-absence (dump 'departed (role 'subscriber c i)))
(on-message [message (dump 'feedback message)]))))))
(define-syntax-rule (wait-as my-orientation topic action ...) (define-syntax-rule (wait-as my-orientation topic action ...)
(endpoint my-orientation topic #:observer (let-fresh (endpoint-name)
#:let-name endpoint-name (build-endpoint endpoint-name
#:state state (role my-orientation topic 'observer)
#:on-presence (sequence-actions (transition state (match-state state
(delete-endpoint endpoint-name) (on-presence (sequence-actions (transition state
action ...)))) (delete-endpoint endpoint-name)
action ...)))))))
(define (session-vm new-conversation) (define (session-vm new-conversation)
(match-define (tcp-channel remote-addr local-addr _) new-conversation) (match-define (tcp-channel remote-addr local-addr _) new-conversation)
@ -98,40 +100,40 @@
(define (read-handshake-and-become-reader) (define (read-handshake-and-become-reader)
(transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't! (transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't!
(at-meta-level (at-meta-level
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?) (name-endpoint 'socket-reader
#:name 'socket-reader (subscriber (tcp-channel remote-addr local-addr ?)
#:state state (match-state state
[(tcp-channel _ _ (? eof-object?)) (on-message
(transition state (quit))] [(tcp-channel _ _ (? eof-object?))
[(tcp-channel _ _ (? bytes? remote-identification)) (transition state (quit))]
(begin [(tcp-channel _ _ (? bytes? remote-identification))
(check-remote-identification! remote-identification) (begin
(sequence-actions (transition state) (check-remote-identification! remote-identification)
;; First, set the incoming mode to bytes. (sequence-actions (transition state)
(at-meta-level ;; First, set the incoming mode to bytes.
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes)))) (at-meta-level
;; Then initialise the reader, switching to packet-reading mode. (send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes))))
(lambda (ignored-state) (ssh-reader new-conversation)) ;; Then initialise the reader, switching to packet-reading mode.
;; Finally, spawn the remaining processes and issue the initial credit to the reader. (lambda (ignored-state) (ssh-reader new-conversation))
(spawn #:debug-name 'ssh-writer ;; Finally, spawn the remaining processes and issue
#:child (ssh-writer new-conversation) ;; the initial credit to the reader.
(name-process 'ssh-writer
;; TODO: canary: #:exit-signal? #t ;; TODO: canary: #:exit-signal? #t
) (spawn (ssh-writer new-conversation)))
;; Wait for the reader and writer get started, then tell ;; Wait for the reader and writer get started, then tell
;; the reader we are ready for a single packet and spawn ;; the reader we are ready for a single packet and spawn
;; the session manager. ;; the session manager.
(wait-as #:subscriber (inbound-packet (wild) (wild) (wild) (wild)) (wait-as 'subscriber (inbound-packet (wild) (wild) (wild) (wild))
(wait-as #:publisher (outbound-packet (wild)) (wait-as 'publisher (outbound-packet (wild))
(send-message (inbound-credit 1)) (send-message (inbound-credit 1))
(spawn #:debug-name 'ssh-session (name-process 'ssh-session
#:pid session-pid (spawn #:pid session-pid
#:child (ssh-session session-pid ;; TODO: canary: #:exit-signal? #t
local-identification (ssh-session session-pid
remote-identification local-identification
repl-boot remote-identification
'server) repl-boot
;; TODO: canary: #:exit-signal? #t 'server)))))))])))))))
)))))]))))
(define (exn->outbound-packet reason) (define (exn->outbound-packet reason)
(outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason) (outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason)
@ -151,13 +153,13 @@
(define interesting? (disconnect-message-required? reason)) (define interesting? (disconnect-message-required? reason))
(transition inert-exception-handler (transition inert-exception-handler
(when interesting? (send-message (exn->outbound-packet reason))) (when interesting? (send-message (exn->outbound-packet reason)))
(yield #:state state ;; gross (yield state ;; gross
(transition state (at-meta-level (quit #:reason (and interesting? reason))))))) (transition state (at-meta-level (quit #f (and interesting? reason)))))))
(define (inert-exception-handler reason) (define (inert-exception-handler reason)
inert-exception-handler) inert-exception-handler)
(nested-vm #:debug-name (list 'ssh-session-vm new-conversation) (spawn-vm #:debug-name (list 'ssh-session-vm new-conversation)
(event-relay 'ssh-event-relay) (event-relay 'ssh-event-relay)
(timer-relay 'ssh-timer-relay) (timer-relay 'ssh-timer-relay)
(spy 'SSH) (spy 'SSH)
@ -170,10 +172,9 @@
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'lines))) (send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'lines)))
(send-feedback (tcp-channel remote-addr local-addr (tcp-credit 1)))) (send-feedback (tcp-channel remote-addr local-addr (tcp-credit 1))))
(spawn #:debug-name 'ssh-reader (name-process 'ssh-reader
#:child (read-handshake-and-become-reader) ;; TODO: canary: #:exit-signal? #t
;; TODO: canary: #:exit-signal? #t (spawn (read-handshake-and-become-reader)))
)
;; TODO: canary: ;; TODO: canary:
;; (spawn #:child ;; (spawn #:child
@ -191,9 +192,9 @@
(event-relay 'app-event-relay) (event-relay 'app-event-relay)
(spy 'APP) (spy 'APP)
(at-meta-level (at-meta-level
(endpoint #:subscriber (channel-message (channel-stream-name #t (wild)) (wild)) (subscriber (channel-message (channel-stream-name #t (wild)) (wild))
#:conversation (channel-message (channel-stream-name _ cname) _) (match-conversation (channel-message (channel-stream-name _ cname) _)
#:on-presence (spawn #:debug-name cname #:child (repl-instance user-name cname)))))) (on-presence (name-process cname (spawn (repl-instance user-name cname)))))))))
;; (repl-instance InputPort OutputPort InputPort OutputPort) ;; (repl-instance InputPort OutputPort InputPort OutputPort)
(struct repl-instance-state (c2s-in ;; used by thread to read input from relay (struct repl-instance-state (c2s-in ;; used by thread to read input from relay
@ -226,28 +227,29 @@
(define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out)))) (define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out))))
(transition state (transition state
(ch-do send-feedback inbound-stream (channel-stream-ok)) (ch-do send-feedback inbound-stream (channel-stream-ok))
(endpoint #:subscriber (cons (thread-dead-evt repl-thread) (wild)) (subscriber (cons (thread-dead-evt repl-thread) (wild))
[_ (quit #:reason "REPL thread exited")]) (on-message [_ (quit #f "REPL thread exited")]))
(endpoint #:subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild)) (subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild))
;; We're using peek-bytes-avail!-evt rather than ;; We're using peek-bytes-avail!-evt rather than
;; read-bytes-avail!-evt because of potential overwriting ;; read-bytes-avail!-evt because of potential overwriting
;; of the buffer. The overwriting can happen when there's ;; of the buffer. The overwriting can happen when there's
;; any latency between handling the event and the next ;; any latency between handling the event and the next
;; firing of the event, since the peek-bytes-avail!-evt ;; firing of the event, since the peek-bytes-avail!-evt
;; will overwrite its buffer next time it's synced on. ;; will overwrite its buffer next time it's synced on.
#:state state (match-state state
[(cons _ (? eof-object?)) (on-message
(let () [(cons _ (? eof-object?))
(match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state) (let ()
(close-input-port c2s-in) (match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
(close-output-port c2s-out) (close-input-port c2s-in)
(close-input-port s2c-in) (close-output-port c2s-out)
(close-output-port s2c-out) (close-input-port s2c-in)
(transition state (quit)))] (close-output-port s2c-out)
[(cons _ (? number? count)) (transition state (quit)))]
(transition state [(cons _ (? number? count))
(ch-do send-message outbound-stream (channel-stream-data (transition state
(read-bytes count s2c-in))))]))] (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 [(or (channel-stream-data #"\4") ;; C-d a.k.a EOT
(channel-stream-eof)) (channel-stream-eof))
(let () (let ()
@ -269,21 +271,21 @@
(define-values (s2c-in s2c-out) (make-pipe)) (define-values (s2c-in s2c-out) (make-pipe))
(transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out) (transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
(at-meta-level (at-meta-level
(endpoint #:subscriber (channel-message inbound-stream (wild)) (subscriber (channel-message inbound-stream (wild))
#:state state (match-state state
#:on-presence (transition state (on-presence (transition state
(ch-do send-feedback inbound-stream (channel-stream-config (ch-do send-feedback inbound-stream (channel-stream-config
(default-packet-limit) (default-packet-limit)
#"")) #""))
(ch-do send-feedback inbound-stream (channel-stream-credit 1024))) (ch-do send-feedback inbound-stream (channel-stream-credit 1024))))
[(channel-message _ body) (on-message
(handle-channel-message state body)])) [(channel-message _ body)
(handle-channel-message state body)]))))
(at-meta-level (at-meta-level
(endpoint #:publisher (channel-message outbound-stream (wild)) (publisher (channel-message outbound-stream (wild))
[m (on-message [m (begin
(begin (write `(channel outbound ,cname ,m)) (newline)
(write `(channel outbound ,cname ,m)) (newline) (void))]))))]
(void))])))]
[type [type
(transition/no-state (transition/no-state
(at-meta-level (send-message (at-meta-level (send-message

View File

@ -514,8 +514,8 @@
(lambda (conn) (lambda (conn)
(transition conn (transition conn
;; TODO: canary for NESTED VM!: #:exit-signal? #t ;; TODO: canary for NESTED VM!: #:exit-signal? #t
(nested-vm #:debug-name 'ssh-application-vm (spawn-vm #:debug-name 'ssh-application-vm
((connection-application-boot conn) user-name)))))] ((connection-application-boot conn) user-name)))))]
[else [else
(transition conn (transition conn
(send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))])) (send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
@ -625,59 +625,61 @@
(define (! conn message) (define (! conn message)
(transition conn (send-message (outbound-packet message)))) (transition conn (send-message (outbound-packet message))))
(list (list
(endpoint #:subscriber (channel-message outbound-stream-name (wild)) (name-endpoint (list cname 'outbound)
#:name (list cname 'outbound) (subscriber (channel-message outbound-stream-name (wild))
#:state conn (match-state conn
#:on-presence (transition conn (on-presence (transition conn
(initial-message-producer inbound-stream-name outbound-stream-name)) (initial-message-producer inbound-stream-name outbound-stream-name)))
#:on-absence (maybe-close-channel cname conn 'local) (on-absence (maybe-close-channel cname conn 'local))
[(channel-message _ body) (on-message
(let () [(channel-message _ body)
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) (let ()
(define remote-ref (ssh-channel-remote-ref ch)) (define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
(match body (define remote-ref (ssh-channel-remote-ref ch))
[(channel-stream-data data-bytes) (match body
;; TODO: split data-bytes into packets if longer than max packet size [(channel-stream-data data-bytes)
(! conn (ssh-msg-channel-data remote-ref data-bytes))] ;; TODO: split data-bytes into packets if longer than max packet size
[(channel-stream-extended-data type data-bytes) (! conn (ssh-msg-channel-data remote-ref data-bytes))]
(! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))] [(channel-stream-extended-data type data-bytes)
[(channel-stream-eof) (! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))]
(! conn (ssh-msg-channel-eof remote-ref))] [(channel-stream-eof)
[(channel-stream-notify type data-bytes) (! conn (ssh-msg-channel-eof remote-ref))]
(! conn (ssh-msg-channel-request remote-ref type #f data-bytes))] [(channel-stream-notify type data-bytes)
[(channel-stream-request type data-bytes) (! conn (ssh-msg-channel-request remote-ref type #f data-bytes))]
(! conn (ssh-msg-channel-request remote-ref type #t data-bytes))] [(channel-stream-request type data-bytes)
[(channel-stream-open-failure reason description) (! conn (ssh-msg-channel-request remote-ref type #t data-bytes))]
(! (discard-channel cname conn) [(channel-stream-open-failure reason description)
(ssh-msg-channel-open-failure remote-ref reason description #""))]))]) (! (discard-channel cname conn)
(endpoint #:publisher (channel-message inbound-stream-name (wild)) (ssh-msg-channel-open-failure remote-ref reason description #""))]))]))))
#:name (list cname 'inbound) (name-endpoint (list cname 'inbound)
#:state conn (publisher (channel-message inbound-stream-name (wild))
[(channel-message _ body) (match-state conn
(let () (on-message
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) [(channel-message _ body)
(define remote-ref (ssh-channel-remote-ref ch)) (let ()
(match body (define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
[(channel-stream-config maximum-packet-size extra-data) (define remote-ref (ssh-channel-remote-ref ch))
(if (channel-name-locally-originated? cname) (match body
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN. [(channel-stream-config maximum-packet-size extra-data)
(! conn (ssh-msg-channel-open (channel-name-type cname) (if (channel-name-locally-originated? cname)
(ssh-channel-local-ref ch) ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN.
0 (! conn (ssh-msg-channel-open (channel-name-type cname)
maximum-packet-size (ssh-channel-local-ref ch)
extra-data)) 0
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION. maximum-packet-size
(! conn (ssh-msg-channel-open-confirmation remote-ref extra-data))
(ssh-channel-local-ref ch) ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION.
0 (! conn (ssh-msg-channel-open-confirmation remote-ref
maximum-packet-size (ssh-channel-local-ref ch)
extra-data)))] 0
[(channel-stream-credit count) maximum-packet-size
(! conn (ssh-msg-channel-window-adjust remote-ref count))] extra-data)))]
[(channel-stream-ok) [(channel-stream-credit count)
(! conn (ssh-msg-channel-success remote-ref))] (! conn (ssh-msg-channel-window-adjust remote-ref count))]
[(channel-stream-fail) [(channel-stream-ok)
(! conn (ssh-msg-channel-failure remote-ref))]))]))) (! conn (ssh-msg-channel-success remote-ref))]
[(channel-stream-fail)
(! conn (ssh-msg-channel-failure remote-ref))]))]))))))
(define (channel-notify conn ch inbound? body) (define (channel-notify conn ch inbound? body)
(transition conn (transition conn
@ -717,16 +719,14 @@
;; application. We are responding to channels appearing from the ;; application. We are responding to channels appearing from the
;; remote peer by virtue of our installation of the handler for ;; remote peer by virtue of our installation of the handler for
;; SSH_MSG_CHANNEL_OPEN above. ;; SSH_MSG_CHANNEL_OPEN above.
(endpoint #:publisher (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
#:observer (match-state conn
#:state conn (match-conversation (channel-message (channel-stream-name #t cname) _)
#:conversation (channel-message (channel-stream-name #t cname) _) (on-presence (respond-to-opened-outbound-channel conn cname)))))
#:on-presence (respond-to-opened-outbound-channel conn cname)) (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
(endpoint #:subscriber (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) (match-state conn
#:observer (match-conversation (channel-message (channel-stream-name #f cname) _)
#:state conn (on-presence (respond-to-opened-outbound-channel conn cname)))))))
#: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) (define (handle-msg-channel-open packet message conn)
(match-define (ssh-msg-channel-open channel-type* (match-define (ssh-msg-channel-open channel-type*
@ -895,28 +895,29 @@
#f #f
application-boot) application-boot)
(endpoint #:subscriber (timer-expired 'rekey-timer (wild)) (subscriber (timer-expired 'rekey-timer (wild))
#:state conn (match-state conn
[(timer-expired 'rekey-timer now) (on-message [(timer-expired 'rekey-timer now)
(sequence-actions (transition conn) (sequence-actions (transition conn)
maybe-rekey)]) maybe-rekey)])))
(endpoint #:subscriber (outbound-byte-credit (wild)) (subscriber (outbound-byte-credit (wild))
#:state conn (match-state conn
[(outbound-byte-credit amount) (on-message [(outbound-byte-credit amount)
(sequence-actions (transition conn) (sequence-actions (transition conn)
(bump-total amount) (bump-total amount)
maybe-rekey)]) maybe-rekey)])))
(endpoint #:subscriber (inbound-packet (wild) (wild) (wild) (wild)) (subscriber (inbound-packet (wild) (wild) (wild) (wild))
#:state conn (match-state conn
[(inbound-packet sequence-number payload message transfer-size) (on-message
(sequence-actions (transition conn) [(inbound-packet sequence-number payload message transfer-size)
(lambda (conn) (sequence-actions (transition conn)
(if (connection-discard-next-packet? conn) (lambda (conn)
(transition (if (connection-discard-next-packet? conn)
(struct-copy connection conn [discard-next-packet? #f])) (transition
(dispatch-packet sequence-number payload message conn))) (struct-copy connection conn [discard-next-packet? #f]))
(bump-total transfer-size) (dispatch-packet sequence-number payload message conn)))
(send-message (inbound-credit 1)) (bump-total transfer-size)
maybe-rekey)]))) (send-message (inbound-credit 1))
maybe-rekey)])))))

View File

@ -310,109 +310,117 @@
(transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0) (transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0)
(at-meta-level (at-meta-level
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?) (name-endpoint 'socket-reader
#:name 'socket-reader (subscriber (tcp-channel remote-addr local-addr ?)
#:state (and state (match-state (and state
(ssh-reader-state mode (ssh-reader-state mode
(crypto-configuration cipher (crypto-configuration cipher
cipher-description cipher-description
hmac hmac
hmac-description) hmac-description)
sequence-number sequence-number
remaining-credit)) remaining-credit))
[(tcp-channel _ _ (? eof-object?)) (on-message
(transition state (quit))] [(tcp-channel _ _ (? eof-object?))
[(tcp-channel _ _ (? bytes? encrypted-packet)) (transition state (quit))]
(let () [(tcp-channel _ _ (? bytes? encrypted-packet))
(define block-size (supported-cipher-block-size cipher-description)) (let ()
(define first-block-size block-size) (define block-size (supported-cipher-block-size cipher-description))
(define subsequent-block-size (if cipher block-size 1)) (define first-block-size block-size)
(define decryptor (if cipher cipher values)) (define subsequent-block-size (if cipher block-size 1))
(define decryptor (if cipher cipher values))
(define (check-hmac packet-length payload-length packet) (define (check-hmac packet-length payload-length packet)
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet)) (define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
(define mac-byte-count (bytes-length computed-hmac-bytes)) (define mac-byte-count (bytes-length computed-hmac-bytes))
(if (positive? mac-byte-count) (if (positive? mac-byte-count)
(transition (struct-copy ssh-reader-state state (transition (struct-copy ssh-reader-state state
[mode `(packet-hmac ,computed-hmac-bytes [mode `(packet-hmac ,computed-hmac-bytes
,mac-byte-count ,mac-byte-count
,packet-length ,packet-length
,payload-length ,payload-length
,packet)]) ,packet)])
(at-meta-level (at-meta-level
(send-feedback (tcp-channel remote-addr local-addr (send-feedback (tcp-channel remote-addr local-addr
(tcp-credit mac-byte-count))))) (tcp-credit mac-byte-count)))))
(finish-packet 0 packet-length payload-length packet))) (finish-packet 0 packet-length payload-length packet)))
(define (finish-packet mac-byte-count 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 bytes-read (+ packet-length mac-byte-count))
(define payload (subbytes packet 5 (+ 5 payload-length))) (define payload (subbytes packet 5 (+ 5 payload-length)))
(define new-credit (- remaining-credit 1)) (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"))]))])))))
(subscriber (inbound-credit (wild))
(match-state state
(on-message
[(inbound-credit amount)
(let ()
(define new-state (struct-copy ssh-reader-state state (define new-state (struct-copy ssh-reader-state state
[mode 'packet-header] [remaining-credit
[sequence-number (+ sequence-number 1)] (+ amount (ssh-reader-state-remaining-credit state))]))
[remaining-credit new-credit]))
(transition new-state (transition new-state
(issue-credit new-state) (issue-credit new-state)))])))
(send-message (subscriber (new-keys (wild)
(inbound-packet sequence-number payload (ssh-message-decode payload) bytes-read)))) (wild)
(wild) (wild)
(match mode (wild) (wild)
['packet-header (wild) (wild))
(define decrypted-packet (decryptor encrypted-packet)) (match-state state
(define first-block decrypted-packet) (on-message
(define packet-length (integer-bytes->integer first-block #f #t 0 4)) [(? new-keys? nk)
(check-packet-length! packet-length packet-size-limit subsequent-block-size) (transition (struct-copy ssh-reader-state state
(define padding-length (bytes-ref first-block 4)) [config (apply-negotiated-options nk #f)]))])))
(define payload-length (- packet-length padding-length 1)) (publisher (inbound-packet (wild) (wild) (wild) (wild)))))
(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 ;; Encrypted Packet Output
@ -423,50 +431,54 @@
(define (ssh-writer new-conversation) (define (ssh-writer new-conversation)
(match-define (tcp-channel remote-addr local-addr _) new-conversation) (match-define (tcp-channel remote-addr local-addr _) new-conversation)
(transition (ssh-writer-state initial-crypto-configuration 0) (transition (ssh-writer-state initial-crypto-configuration 0)
(endpoint #:publisher (outbound-byte-credit (wild))) (publisher (outbound-byte-credit (wild)))
(endpoint #:subscriber (outbound-packet (wild)) (subscriber (outbound-packet (wild))
#:state (and state (match-state (and state
(ssh-writer-state (crypto-configuration cipher (ssh-writer-state (crypto-configuration cipher
cipher-description cipher-description
hmac hmac
hmac-description) hmac-description)
sequence-number)) sequence-number))
[(outbound-packet message) (on-message
(let () [(outbound-packet message)
(define pad-block-size (supported-cipher-block-size cipher-description)) (let ()
(define encryptor (if cipher cipher values)) (define pad-block-size (supported-cipher-block-size cipher-description))
(define payload (ssh-message-encode message)) (define encryptor (if cipher cipher values))
;; There must be at least 4 bytes of padding, and padding needs to (define payload (ssh-message-encode message))
;; make the packet length a multiple of pad-block-size. ;; There must be at least 4 bytes of padding, and padding needs to
(define unpadded-length (+ 4 ;; length of length ;; make the packet length a multiple of pad-block-size.
1 ;; length of length-of-padding indicator (define unpadded-length (+ 4 ;; length of length
(bit-string-byte-count payload))) 1 ;; length of length-of-padding indicator
(define min-padded-length (+ unpadded-length 4)) (bit-string-byte-count payload)))
(define padded-length (round-up min-padded-length pad-block-size)) (define min-padded-length (+ unpadded-length 4))
(define padding-length (- padded-length unpadded-length)) (define padded-length (round-up min-padded-length pad-block-size))
(define packet-length (- padded-length 4)) ;; the packet length does *not* include itself! (define padding-length (- padded-length unpadded-length))
(define packet (bit-string->bytes (define packet-length (- padded-length 4))
(bit-string (packet-length :: integer bits 32) ;; ^^ the packet length does *not* include itself!
(padding-length :: integer bits 8) (define packet (bit-string->bytes
(payload :: binary) (bit-string (packet-length :: integer bits 32)
((random-bytes padding-length) :: binary)))) (padding-length :: integer bits 8)
(define encrypted-packet (encryptor packet)) (payload :: binary)
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet)) ((random-bytes padding-length) :: binary))))
(define mac-byte-count (bytes-length computed-hmac-bytes)) (define encrypted-packet (encryptor packet))
(transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)]) (define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
(at-meta-level (define mac-byte-count (bytes-length computed-hmac-bytes))
(send-message (tcp-channel local-addr remote-addr encrypted-packet))) (transition (struct-copy ssh-writer-state state
(when (positive? mac-byte-count) [sequence-number (+ sequence-number 1)])
(at-meta-level (at-meta-level
(send-message (tcp-channel local-addr remote-addr computed-hmac-bytes)))) (send-message (tcp-channel local-addr remote-addr encrypted-packet)))
(send-message (when (positive? mac-byte-count)
(outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count)))))]) (at-meta-level
(endpoint #:subscriber (new-keys (wild) (send-message (tcp-channel local-addr remote-addr computed-hmac-bytes))))
(wild) (send-message
(wild) (wild) (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count)))))])))
(wild) (wild) (subscriber (new-keys (wild)
(wild) (wild)) (wild)
#:state state (wild) (wild)
[(? new-keys? nk) (wild) (wild)
(transition (wild) (wild))
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))]))) (match-state state
(on-message
[(? new-keys? nk)
(transition
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))))