Convert to extrasugar
This commit is contained in:
Tony Garnock-Jones
parent
8c4c95f1a6
commit
024b6b75cc
190
new-server.rkt
190
new-server.rkt
|
|
@ -38,14 +38,13 @@
|
|||
(ground-vm (timer-driver)
|
||||
(tcp-driver)
|
||||
(tcp-spy)
|
||||
(spawn #:debug-name 'ssh-tcp-listener #:child listener)))
|
||||
(name-process 'ssh-tcp-listener (spawn listener))))
|
||||
|
||||
(define listener
|
||||
(transition/no-state
|
||||
(endpoint #:subscriber (tcp-channel ? (tcp-listener 2322) ?)
|
||||
#:observer
|
||||
#:conversation r
|
||||
#:on-presence (session-vm r))))
|
||||
(observe-publishers (tcp-channel ? (tcp-listener 2322) ?)
|
||||
(match-conversation r
|
||||
(on-presence (session-vm r))))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -67,24 +66,27 @@
|
|||
(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)])))
|
||||
(observe-publishers/everything (wild)
|
||||
(match-interest-type i
|
||||
(match-conversation c
|
||||
(on-presence (dump 'arrived (role 'publisher c i)))
|
||||
(on-absence (dump 'departed (role 'publisher c i)))
|
||||
(on-message [message (dump 'message message)]))))
|
||||
(observe-subscribers/everything (wild)
|
||||
(match-interest-type i
|
||||
(match-conversation c
|
||||
(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 ...)
|
||||
(endpoint my-orientation topic #:observer
|
||||
#:let-name endpoint-name
|
||||
#:state state
|
||||
#:on-presence (sequence-actions (transition state
|
||||
(delete-endpoint endpoint-name)
|
||||
action ...))))
|
||||
(let-fresh (endpoint-name)
|
||||
(build-endpoint endpoint-name
|
||||
(role my-orientation topic 'observer)
|
||||
(match-state state
|
||||
(on-presence (sequence-actions (transition state
|
||||
(delete-endpoint endpoint-name)
|
||||
action ...)))))))
|
||||
|
||||
(define (session-vm new-conversation)
|
||||
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
||||
|
|
@ -98,40 +100,40 @@
|
|||
(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)
|
||||
(name-endpoint 'socket-reader
|
||||
(subscriber (tcp-channel remote-addr local-addr ?)
|
||||
(match-state state
|
||||
(on-message
|
||||
[(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.
|
||||
(name-process 'ssh-writer
|
||||
;; 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.
|
||||
(wait-as #:subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||
(wait-as #:publisher (outbound-packet (wild))
|
||||
(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
|
||||
)))))]))))
|
||||
(spawn (ssh-writer new-conversation)))
|
||||
;; Wait for the reader and writer get started, then tell
|
||||
;; the reader we are ready for a single packet and spawn
|
||||
;; the session manager.
|
||||
(wait-as 'subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||
(wait-as 'publisher (outbound-packet (wild))
|
||||
(send-message (inbound-credit 1))
|
||||
(name-process 'ssh-session
|
||||
(spawn #:pid session-pid
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
(ssh-session session-pid
|
||||
local-identification
|
||||
remote-identification
|
||||
repl-boot
|
||||
'server)))))))])))))))
|
||||
|
||||
(define (exn->outbound-packet reason)
|
||||
(outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason)
|
||||
|
|
@ -151,13 +153,13 @@
|
|||
(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)))))))
|
||||
(yield state ;; gross
|
||||
(transition state (at-meta-level (quit #f (and interesting? reason)))))))
|
||||
|
||||
(define (inert-exception-handler reason)
|
||||
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)
|
||||
(timer-relay 'ssh-timer-relay)
|
||||
(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-credit 1))))
|
||||
|
||||
(spawn #:debug-name 'ssh-reader
|
||||
#:child (read-handshake-and-become-reader)
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
)
|
||||
(name-process 'ssh-reader
|
||||
;; TODO: canary: #:exit-signal? #t
|
||||
(spawn (read-handshake-and-become-reader)))
|
||||
|
||||
;; TODO: canary:
|
||||
;; (spawn #:child
|
||||
|
|
@ -191,9 +192,9 @@
|
|||
(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))))))
|
||||
(subscriber (channel-message (channel-stream-name #t (wild)) (wild))
|
||||
(match-conversation (channel-message (channel-stream-name _ cname) _)
|
||||
(on-presence (name-process cname (spawn (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
|
||||
|
|
@ -226,28 +227,29 @@
|
|||
(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))
|
||||
(subscriber (cons (thread-dead-evt repl-thread) (wild))
|
||||
(on-message [_ (quit #f "REPL thread exited")]))
|
||||
(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))))]))]
|
||||
(match-state state
|
||||
(on-message
|
||||
[(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 ()
|
||||
|
|
@ -269,21 +271,21 @@
|
|||
(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)]))
|
||||
(subscriber (channel-message inbound-stream (wild))
|
||||
(match-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))))
|
||||
(on-message
|
||||
[(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))])))]
|
||||
(publisher (channel-message outbound-stream (wild))
|
||||
(on-message [m (begin
|
||||
(write `(channel outbound ,cname ,m)) (newline)
|
||||
(void))]))))]
|
||||
[type
|
||||
(transition/no-state
|
||||
(at-meta-level (send-message
|
||||
|
|
|
|||
177
ssh-session.rkt
177
ssh-session.rkt
|
|
@ -514,8 +514,8 @@
|
|||
(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)))))]
|
||||
(spawn-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))))]))
|
||||
|
|
@ -625,59 +625,61 @@
|
|||
(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))]))])))
|
||||
(name-endpoint (list cname 'outbound)
|
||||
(subscriber (channel-message outbound-stream-name (wild))
|
||||
(match-state conn
|
||||
(on-presence (transition conn
|
||||
(initial-message-producer inbound-stream-name outbound-stream-name)))
|
||||
(on-absence (maybe-close-channel cname conn 'local))
|
||||
(on-message
|
||||
[(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 #""))]))]))))
|
||||
(name-endpoint (list cname 'inbound)
|
||||
(publisher (channel-message inbound-stream-name (wild))
|
||||
(match-state conn
|
||||
(on-message
|
||||
[(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
|
||||
|
|
@ -717,16 +719,14 @@
|
|||
;; 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))))
|
||||
(observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
|
||||
(match-state conn
|
||||
(match-conversation (channel-message (channel-stream-name #t cname) _)
|
||||
(on-presence (respond-to-opened-outbound-channel conn cname)))))
|
||||
(observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
|
||||
(match-state conn
|
||||
(match-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*
|
||||
|
|
@ -895,28 +895,29 @@
|
|||
#f
|
||||
application-boot)
|
||||
|
||||
(endpoint #:subscriber (timer-expired 'rekey-timer (wild))
|
||||
#:state conn
|
||||
[(timer-expired 'rekey-timer now)
|
||||
(sequence-actions (transition conn)
|
||||
maybe-rekey)])
|
||||
(subscriber (timer-expired 'rekey-timer (wild))
|
||||
(match-state conn
|
||||
(on-message [(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)])
|
||||
(subscriber (outbound-byte-credit (wild))
|
||||
(match-state conn
|
||||
(on-message [(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)])))
|
||||
(subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||
(match-state conn
|
||||
(on-message
|
||||
[(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)])))))
|
||||
|
|
|
|||
|
|
@ -310,109 +310,117 @@
|
|||
|
||||
(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))
|
||||
(name-endpoint 'socket-reader
|
||||
(subscriber (tcp-channel remote-addr local-addr ?)
|
||||
(match-state (and state
|
||||
(ssh-reader-state mode
|
||||
(crypto-configuration cipher
|
||||
cipher-description
|
||||
hmac
|
||||
hmac-description)
|
||||
sequence-number
|
||||
remaining-credit))
|
||||
(on-message
|
||||
[(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 (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 (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"))]))])))))
|
||||
(subscriber (inbound-credit (wild))
|
||||
(match-state state
|
||||
(on-message
|
||||
[(inbound-credit amount)
|
||||
(let ()
|
||||
(define new-state (struct-copy ssh-reader-state state
|
||||
[mode 'packet-header]
|
||||
[sequence-number (+ sequence-number 1)]
|
||||
[remaining-credit new-credit]))
|
||||
[remaining-credit
|
||||
(+ amount (ssh-reader-state-remaining-credit state))]))
|
||||
(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)))))
|
||||
(issue-credit new-state)))])))
|
||||
(subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild))
|
||||
(match-state state
|
||||
(on-message
|
||||
[(? new-keys? nk)
|
||||
(transition (struct-copy ssh-reader-state state
|
||||
[config (apply-negotiated-options nk #f)]))])))
|
||||
(publisher (inbound-packet (wild) (wild) (wild) (wild)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Encrypted Packet Output
|
||||
|
|
@ -423,50 +431,54 @@
|
|||
(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)]))])))
|
||||
(publisher (outbound-byte-credit (wild)))
|
||||
(subscriber (outbound-packet (wild))
|
||||
(match-state (and state
|
||||
(ssh-writer-state (crypto-configuration cipher
|
||||
cipher-description
|
||||
hmac
|
||||
hmac-description)
|
||||
sequence-number))
|
||||
(on-message
|
||||
[(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)))))])))
|
||||
(subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild))
|
||||
(match-state state
|
||||
(on-message
|
||||
[(? new-keys? nk)
|
||||
(transition
|
||||
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue