From 9501a73fc552e98479a657f662d44fcaff79e7c6 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 22 Jun 2012 13:14:02 -0400 Subject: [PATCH] Improvements from codewalk with Sam and Matthias --- new-server.rkt | 203 ++++++++++++++++++++++++++++--------------------- 1 file changed, 115 insertions(+), 88 deletions(-) diff --git a/new-server.rkt b/new-server.rkt index db268b6..ff338a7 100644 --- a/new-server.rkt +++ b/new-server.rkt @@ -14,6 +14,36 @@ (define server-addr (tcp-listener 2322)) +(define (main) + (ground-vm + (transition 'no-state + (spawn (timer-driver 'timer-driver)) + ;; PAPER NOTE: remove #:debug-name for presentation economy + (spawn tcp-driver #:debug-name 'tcp-driver) + (spawn tcp-spy #:debug-name 'tcp-spy) + (spawn listener)))) + +(define listener + (transition 'no-state + (role 'connection-waiter (topic-subscriber (tcp-channel (wild) server-addr (wild)) + #:virtual? #t) + #:state state + #:topic t + #:on-presence (match t + [(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #f) + (transition state + (spawn (session-vm server-addr remote-addr) + #:debug-name (list 'ssh-session-vm remote-addr)))] + ;; PAPER NOTE: This second clause can be replaced with + ;; [_ state] for presentation economy + [(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #t) + ;; Ignore virtual flows. They just mean there's + ;; someone willing to supply connections to us + ;; at some point in the future. + state])))) + +;;--------------------------------------------------------------------------- + (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 @@ -88,105 +118,102 @@ SSH_OPEN_UNKNOWN_CHANNEL_TYPE (bytes-append #"Unknown channel type " type))))))])) -(define (connection-handler local-addr remote-addr) +(define (spy marker) + (role 'spy (or (topic-subscriber (wild) #:virtual? #t) + (topic-publisher (wild) #:virtual? #t)) + #:state state + [message + (write `(,marker ,message)) + (newline) + (flush-output) + state])) + +(define (session-vm local-addr remote-addr) (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 + (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)) + (check-remote-identification! 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/monitor (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 and spawn the session manager. + (yield #:state state + (transition state + (send-message (inbound-credit 1)) + (spawn/monitor (ssh-session local-identification + remote-identification + repl-boot + 'server) + #:debug-name 'ssh-session))))])))) + + (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 monitors %%% + (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 (kill #:reason (and interesting? reason))))))) + + (define (inert-exception-handler reason) + inert-exception-handler) + (nested-vm (list 'ssh-session-vm remote-addr) + ;; TODO: use (not-yet-existing) macro variant of nested-vm to avoid + ;; spuriously binding nested-boot-pid without blaming the wrong + ;; process in case of error. (lambda (nested-boot-pid) - (transition 'running + (transition 'no-state (spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay) + (spy 'SSH) - ;; Issue identification string. - (at-meta-level - (send-message (tcp-channel local-addr - remote-addr - (bytes-append local-identification #"\r\n")))) + (issue-identification-string) ;; 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/monitor - (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)) - (check-remote-identification! 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/monitor (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 and spawn the session manager. - (yield #:state state - (transition state - (send-message (inbound-credit 1)) - (spawn/monitor (ssh-session local-identification - remote-identification - repl-boot - 'server) - #:debug-name 'ssh-session))))]))) - #:debug-name 'ssh-reader) + (spawn/monitor (read-handshake-and-become-reader) #:debug-name 'ssh-reader) - (role 'spy (or (topic-subscriber (wild) #:virtual? #t) - (topic-publisher (wild) #:virtual? #t)) - #:state state - [message - (write `(SSH ,message)) - (newline) - (flush-output) - state]) + (spawn (transition active-exception-handler + (role 'monitor-listener (topic-subscriber (monitor (wild) (wild))) + #:state current-handler + #:reason reason + #:on-absence (current-handler reason)))))))) - (role 'monitor-listener (topic-subscriber (monitor (wild) (wild))) - #: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. - ;; TODO: this is likely no longer true now we're using monitors %%% - (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)))))) - -(ground-vm - (transition 'no-state - (spawn (timer-driver 'timer-driver)) - (spawn tcp-driver #:debug-name 'tcp-driver) - (spawn tcp-spy #:debug-name 'tcp-spy) - - (spawn (transition 'no-state - (role 'connection-waiter (topic-subscriber (tcp-channel (wild) server-addr (wild)) - #:virtual? #t) - #:state state - #:topic t - #:on-presence (match t - [(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #t) - ;; Ignore virtual flows. They just mean there's - ;; someone willing to supply connections to us - ;; at some point in the future. - state] - [(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #f) - (transition state - (spawn (connection-handler server-addr remote-addr) - #:debug-name (list 'ssh-session-vm remote-addr)))])))))) +;; TODO: module+ +(main)