diff --git a/new-server.rkt b/new-server.rkt index 44ea95e..eb1b311 100644 --- a/new-server.rkt +++ b/new-server.rkt @@ -13,47 +13,74 @@ (define server-addr (tcp-listener 2322)) (define (connection-handler local-addr remote-addr) + (define local-identification #"SSH-2.0-RacketSSH_0.0") (nested-vm (list 'ssh-session-vm remote-addr) - (transition 'running - (at-meta-level - (send-message (tcp-channel local-addr remote-addr #"SSH-2.0-RacketSSH_0.0\r\n"))) - (at-meta-level (send-tcp-mode remote-addr local-addr 'lines)) - (at-meta-level (send-tcp-credit remote-addr local-addr 1)) - (at-meta-level - (role 'identification-handler (topic-subscriber %%% + (lambda (nested-boot-pid) + (transition 'running - (spawn (ssh-reader local-addr remote-addr) #:debug-name 'ssh-reader) - (spawn (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer) - (yield #:state state - (transition state (send-message (inbound-credit 1)))) - (role 'crash-listener - (set (topic-subscriber (wild) #:virtual? #t) - (topic-publisher (wild) #:virtual? #t)) - #:state state - #:reason reason - #:on-absence - ;; 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. - (if (eq? state 'running) - (if (and (exn:fail:contract:protocol? reason) - (not (exn:fail:contract:protocol-originated-at-peer? reason))) - (transition 'error-packet-sent - (send-message (outbound-packet (ssh-msg-disconnect - (exn:fail:contract:protocol-reason-code reason) - (string->bytes/utf-8 (exn-message reason)) - #""))) - (yield #:state state - (transition state (at-meta-level (kill))))) - (transition state (at-meta-level (kill #:reason reason)))) - state) - [msg - (write (list 'SSH msg)) - (newline) - (flush-output) - state])))) + ;; Issue identification string. + (at-meta-level + (send-message (tcp-channel local-addr + remote-addr + (bytes-append local-identification #"\r\n")))) + + ;; Expect identification string, then update (!) our inbound + ;; subscription handler to switch to packet mode. + + (at-meta-level (send-tcp-mode remote-addr local-addr 'lines)) + (at-meta-level (send-tcp-credit remote-addr local-addr 1)) + + (spawn + (transition 'handshake-is-stateless + (at-meta-level + (role 'socket-reader (topic-subscriber (tcp-channel remote-addr local-addr (wild))) + #:state state + [(tcp-channel _ _ (? eof-object?)) + (transition state (kill))] + [(tcp-channel _ _ (? bytes? remote-identification)) + ;; First, set the incoming mode to bytes. Then + ;; initialise the reader, switching to packet-reading + ;; mode. Finally, spawn the remaining processes and + ;; issue the initial credit to the reader. + (extend-transition + (prefix-transition (ssh-reader local-addr remote-addr) + (at-meta-level (send-tcp-mode remote-addr local-addr 'bytes))) + (spawn (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer) + ;; Wait for a cycle to let the reader and writer get + ;; started, then tell the reader we are ready for a + ;; single packet. + (yield #:state state + (transition state (send-message (inbound-credit 1)))))]))) + #:debug-name 'ssh-reader) + + (role 'crash-listener + (set (topic-subscriber (wild) #:virtual? #t) + (topic-publisher (wild) #:virtual? #t)) + #:state state + #:reason reason + #:on-absence + ;; 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. + (if (eq? state 'running) + (if (and (exn:fail:contract:protocol? reason) + (not (exn:fail:contract:protocol-originated-at-peer? reason))) + (transition 'error-packet-sent + (send-message (outbound-packet (ssh-msg-disconnect + (exn:fail:contract:protocol-reason-code reason) + (string->bytes/utf-8 (exn-message reason)) + #""))) + (yield #:state state + (transition state (at-meta-level (kill))))) + (transition state (at-meta-level (kill #:reason reason)))) + state) + [msg + (write (list 'SSH msg)) + (newline) + (flush-output) + state]))))) (ground-vm (transition 'no-state diff --git a/ssh-transport.rkt b/ssh-transport.rkt index 39bd73f..31b445f 100644 --- a/ssh-transport.rkt +++ b/ssh-transport.rkt @@ -300,6 +300,8 @@ hmac-description) sequence-number remaining-credit)) + [(tcp-channel _ _ (? eof-object?)) + (transition state (kill))] [(tcp-channel _ _ (? bytes? encrypted-packet)) (define block-size (supported-cipher-block-size cipher-description)) (define first-block-size block-size)