From e94acab878a2d4c973b55708ba062435529b1ead Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 23 Jul 2012 15:23:17 -0400 Subject: [PATCH] Make role names optional, and remove role/anon. Remove inessential role names from apps. Make nested-vm a macro. --- new-server.rkt | 64 +++++++++++++++++++++-------------------------- ssh-session.rkt | 20 ++++++++------- ssh-transport.rkt | 35 ++++++++++++-------------- 3 files changed, 56 insertions(+), 63 deletions(-) diff --git a/new-server.rkt b/new-server.rkt index 75422da..6952c91 100644 --- a/new-server.rkt +++ b/new-server.rkt @@ -27,7 +27,7 @@ (define listener (transition 'no-state - (role 'connection-waiter (tcp-listener 2322) + (role (tcp-listener 2322) #:topic t #:on-presence (spawn (session-vm t) #:debug-name (debug-name 'ssh-session-vm t))))) @@ -45,8 +45,8 @@ peer-identification-string))) (define (spy marker) - (role 'spy (or (topic-subscriber (wild) #:monitor? #t) - (topic-publisher (wild) #:monitor? #t)) + (role (or (topic-subscriber (wild) #:monitor? #t) + (topic-publisher (wild) #:monitor? #t)) #:state state [message (write `(,marker ,message)) @@ -71,7 +71,8 @@ (define (read-handshake-and-become-reader) (transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't! (at-meta-level - (role 'socket-reader in-topic + (role in-topic + #:name 'socket-reader #:state state [(tcp-channel _ _ (? eof-object?)) (transition state (kill))] @@ -125,43 +126,37 @@ (define (inert-exception-handler reason) inert-exception-handler) - (nested-vm - (debug-name 'ssh-session-vm new-connection-topic) - ;; 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 'no-state - (spawn event-relay #:debug-name (debug-name 'session-event-relay)) - (spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay) - (spy 'SSH) + (nested-vm #:debug-name (debug-name 'ssh-session-vm new-connection-topic) + (transition 'no-state + (spawn event-relay #:debug-name (debug-name 'session-event-relay)) + (spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay) + (spy 'SSH) - (issue-identification-string) + (issue-identification-string) - ;; Expect identification string, then update (!) our inbound - ;; subscription handler to switch to packet mode. - (at-meta-level (cin (tcp-mode 'lines))) - (at-meta-level (cin (tcp-credit 1))) + ;; Expect identification string, then update (!) our inbound + ;; subscription handler to switch to packet mode. + (at-meta-level (cin (tcp-mode 'lines))) + (at-meta-level (cin (tcp-credit 1))) - (spawn (read-handshake-and-become-reader) - #:exit-signal? #t - #:debug-name 'ssh-reader) + (spawn (read-handshake-and-become-reader) + #:exit-signal? #t + #:debug-name 'ssh-reader) - (spawn (transition active-exception-handler - (role 'exit-signal-listener (topic-subscriber (exit-signal (wild) (wild))) - #:state current-handler - #:reason reason - #:on-absence (current-handler reason)))))))) + (spawn (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) self-pid) +(define (repl-boot user-name) (transition 'no-repl-state (spawn event-relay #:debug-name (debug-name 'repl-event-relay)) (spy 'APP) (at-meta-level - (role 'channel-listener (topic-subscriber (channel-message (channel-stream-name #t (wild)) - (wild))) + (role (topic-subscriber (channel-message (channel-stream-name #t (wild)) (wild))) #:state state #:topic t #:on-presence (match t @@ -201,13 +196,12 @@ (define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out)))) (transition state (ch-do send-feedback inbound-stream (channel-stream-ok)) - (role 'thread-death-listener (topic-subscriber (cons (thread-dead-evt repl-thread) (wild))) + (role (topic-subscriber (cons (thread-dead-evt repl-thread) (wild))) #:state state [_ (transition state (kill #:reason "REPL thread exited"))]) - (role 'relay-out (topic-subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) - (wild))) + (role (topic-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 @@ -246,7 +240,7 @@ (define-values (s2c-in s2c-out) (make-pipe)) (transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out) (at-meta-level - (role 'input (topic-subscriber (channel-message inbound-stream (wild))) + (role (topic-subscriber (channel-message inbound-stream (wild))) #:state state #:on-presence (transition state (ch-do send-feedback inbound-stream (channel-stream-config @@ -256,7 +250,7 @@ [(channel-message _ body) (handle-channel-message state body)])) (at-meta-level - (role 'output (topic-publisher (channel-message outbound-stream (wild))) + (role (topic-publisher (channel-message outbound-stream (wild))) #:state state [m (write `(channel outbound ,cname ,m)) (newline) diff --git a/ssh-session.rkt b/ssh-session.rkt index f60a97c..89800cf 100644 --- a/ssh-session.rkt +++ b/ssh-session.rkt @@ -489,7 +489,8 @@ conn)))) (lambda (conn) (transition conn - (spawn (nested-vm 'ssh-application-vm ((connection-application-boot conn) user-name)) + (spawn (nested-vm #:debug-name 'ssh-application-vm + ((connection-application-boot conn) user-name)) #:exit-signal? #t #:debug-name 'ssh-application-vm))))] [else @@ -601,7 +602,8 @@ (define (! conn message) (transition conn (send-message (outbound-packet message)))) (list - (role (list cname 'outbound) (topic-subscriber (channel-message outbound-stream-name (wild))) + (role (topic-subscriber (channel-message outbound-stream-name (wild))) + #:name (list cname 'outbound) #:state conn #:on-presence (transition conn @@ -626,7 +628,8 @@ [(channel-stream-open-failure reason description) (! (discard-channel cname conn) (ssh-msg-channel-open-failure remote-ref reason description #""))])]) - (role (list cname 'inbound) (topic-publisher (channel-message inbound-stream-name (wild))) + (role (topic-publisher (channel-message inbound-stream-name (wild))) + #:name (list cname 'inbound) #:state conn [(channel-message _ body) (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) @@ -686,9 +689,8 @@ ;; 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. - (role 'channel-connector - (set (topic-publisher arbitrary-locally-originated-traffic #:monitor? #t) - (topic-subscriber arbitrary-locally-originated-traffic #:monitor? #t)) + (role (set (topic-publisher arbitrary-locally-originated-traffic #:monitor? #t) + (topic-subscriber arbitrary-locally-originated-traffic #:monitor? #t)) #:state conn #:topic t #:on-presence @@ -869,20 +871,20 @@ #f application-boot) - (role 'rekey-waiter (topic-subscriber (timer-expired 'rekey-timer (wild))) + (role (topic-subscriber (timer-expired 'rekey-timer (wild))) #:state conn [(timer-expired 'rekey-timer now) (sequence-actions conn maybe-rekey)]) - (role 'credit-listener (topic-subscriber (outbound-byte-credit (wild))) + (role (topic-subscriber (outbound-byte-credit (wild))) #:state conn [(outbound-byte-credit amount) (sequence-actions conn (bump-total amount) maybe-rekey)]) - (role 'packet-listener (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild))) + (role (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild))) #:state conn [(inbound-packet sequence-number payload message transfer-size) (sequence-actions conn diff --git a/ssh-transport.rkt b/ssh-transport.rkt index 53392d3..a479d28 100644 --- a/ssh-transport.rkt +++ b/ssh-transport.rkt @@ -290,7 +290,8 @@ (transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0) (at-meta-level - (role 'socket-reader in-topic + (role in-topic + #:name 'socket-reader #:state (and state (ssh-reader-state mode (crypto-configuration cipher @@ -369,7 +370,7 @@ (actual-hmac ,received-hmac-bytes)) SSH_DISCONNECT_MAC_ERROR "Corrupt MAC"))])])) - (role 'credit-listener (topic-subscriber (inbound-credit (wild))) + (role (topic-subscriber (inbound-credit (wild))) #:state state [(inbound-credit amount) (define new-state (struct-copy ssh-reader-state state @@ -377,17 +378,15 @@ (+ amount (ssh-reader-state-remaining-credit state))])) (transition new-state (issue-credit new-state))]) - (role 'key-change-listener - (topic-subscriber (new-keys (wild) - (wild) - (wild) (wild) - (wild) (wild) - (wild) (wild))) + (role (topic-subscriber (new-keys (wild) + (wild) + (wild) (wild) + (wild) (wild) + (wild) (wild))) #:state state [(? new-keys? nk) (struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)])]) - (role 'packet-publisher (topic-publisher (inbound-packet (wild) (wild) (wild) (wild))) - #:state state))) + (role (topic-publisher (inbound-packet (wild) (wild) (wild) (wild)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Encrypted Packet Output @@ -398,9 +397,8 @@ (define (ssh-writer new-connection-topic) (define-values (cin cout in-topic out-topic) (tcp-accept new-connection-topic)) (transition (ssh-writer-state initial-crypto-configuration 0) - (role 'packet-listener - (set (topic-subscriber (outbound-packet (wild))) - (topic-publisher (outbound-byte-credit (wild)))) + (role (set (topic-subscriber (outbound-packet (wild))) + (topic-publisher (outbound-byte-credit (wild)))) #:state (and state (ssh-writer-state (crypto-configuration cipher cipher-description @@ -433,12 +431,11 @@ (when (positive? mac-byte-count) (at-meta-level (cout computed-hmac-bytes))) (send-message (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count))))]) - (role 'key-change-listener - (topic-subscriber (new-keys (wild) - (wild) - (wild) (wild) - (wild) (wild) - (wild) (wild))) + (role (topic-subscriber (new-keys (wild) + (wild) + (wild) (wild) + (wild) (wild) + (wild) (wild))) #:state state [(? new-keys? nk) (struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)])])))