From ff2cd74339f81c1945c8136eb6e9ab23db0696fb Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 23 Jul 2012 17:21:47 -0400 Subject: [PATCH] Make handlers etc *required* to return a transition structure. --- new-server.rkt | 25 ++--- ssh-session.rkt | 244 ++++++++++++++++++++++++---------------------- ssh-transport.rkt | 5 +- 3 files changed, 137 insertions(+), 137 deletions(-) diff --git a/new-server.rkt b/new-server.rkt index 6952c91..69e0ef6 100644 --- a/new-server.rkt +++ b/new-server.rkt @@ -47,17 +47,16 @@ (define (spy marker) (role (or (topic-subscriber (wild) #:monitor? #t) (topic-publisher (wild) #:monitor? #t)) - #:state state [message (write `(,marker ,message)) (newline) (flush-output) - state])) + (void)])) -(define-syntax-rule (wait-for topic-of-interest #:state state action ...) +(define-syntax-rule (wait-for topic-of-interest action ...) (role/fresh role-name topic-of-interest #:state state - #:on-presence (sequence-actions state + #:on-presence (sequence-actions (transition state) (delete-role role-name) action ...))) @@ -78,7 +77,7 @@ (transition state (kill))] [(tcp-channel _ _ (? bytes? remote-identification)) (check-remote-identification! remote-identification) - (sequence-actions state + (sequence-actions (transition state) ;; First, set the incoming mode to bytes. (at-meta-level (cin (tcp-mode 'bytes))) ;; Then initialise the reader, switching to packet-reading mode. @@ -91,9 +90,7 @@ ;; the reader we are ready for a single packet and spawn ;; the session manager. (wait-for (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)) #:monitor? #t) - #:state state (wait-for (topic-publisher (outbound-packet (wild)) #:monitor? #t) - #:state state (send-message (inbound-credit 1)) (spawn (ssh-session local-identification remote-identification @@ -188,7 +185,7 @@ (ch-do send-feedback inbound-stream (channel-stream-ok)))] [(channel-stream-notify #"env" _) ;; Don't care - state] + (transition state)] [(channel-stream-request #"shell" _) (match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state) (define buffer-size 1024) @@ -197,10 +194,7 @@ (transition state (ch-do send-feedback inbound-stream (channel-stream-ok)) (role (topic-subscriber (cons (thread-dead-evt repl-thread) (wild))) - #:state state - [_ - (transition state - (kill #:reason "REPL thread exited"))]) + [_ (kill #:reason "REPL thread exited")]) (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 @@ -225,7 +219,7 @@ (close-output-port (repl-instance-state-c2s-out state)) ;; ^ this signals the repl thread to exit. ;; Now, wait for it to do so. - state] + (transition state)] [(channel-stream-data bs) (write-bytes bs (repl-instance-state-c2s-out state)) (flush-output (repl-instance-state-c2s-out state)) @@ -233,7 +227,7 @@ (ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))] [m (write `(channel inbound ,m)) (newline) - state])) + (transition state)])) (match (channel-name-type cname) [#"session" (define-values (c2s-in c2s-out) (make-pipe)) @@ -251,10 +245,9 @@ (handle-channel-message state body)])) (at-meta-level (role (topic-publisher (channel-message outbound-stream (wild))) - #:state state [m (write `(channel outbound ,cname ,m)) (newline) - state])))] + (void)])))] [type (transition 'no-instance-state (at-meta-level (send-message diff --git a/ssh-session.rkt b/ssh-session.rkt index 89800cf..59b5e4f 100644 --- a/ssh-session.rkt +++ b/ssh-session.rkt @@ -179,7 +179,7 @@ ;; PacketHandler for handling SSH_MSG_IGNORE. (define (handle-msg-ignore packet message conn) - conn) + (transition conn)) ;; PacketHandler for handling SSH_MSG_UNIMPLEMENTED. (define (handle-msg-unimplemented packet message conn) @@ -191,7 +191,7 @@ ;; PacketHandler for handling SSH_MSG_DEBUG. (define (handle-msg-debug packet message conn) (log-debug (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message)) - conn) + (transition conn)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Key Exchange @@ -251,33 +251,35 @@ dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2 (define-values (private-key public-key) (generate-key group)) (define public-key-as-integer (bit-string->integer public-key #t #f)) - (oneshot-handler conn - SSH_MSG_KEXDH_INIT - (lambda (packet message conn) - (define e (ssh-msg-kexdh-init-e message)) - (define e-width (mpint-width e)) - (define e-as-bytes (integer->bit-string e (* 8 e-width) #t)) - (define shared-secret (compute-key private-key e-as-bytes)) - (define hash-alg sha1) - (define-values (host-key-private host-key-public) - (host-key-algorithm->keys host-key-alg)) - (define host-key-bytes - (pieces->ssh-host-key (public-key->pieces host-key-public))) - (define exchange-hash - (dh-exchange-hash hash-info - host-key-bytes - e - public-key-as-integer - (bit-string->integer shared-secret #t #f))) - (define h-signature (host-key-signature host-key-private - host-key-alg - exchange-hash)) - (sequence-actions conn - (send-message (outbound-packet - (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes) - public-key-as-integer - (bit-string->bytes h-signature)))) - (lambda (conn) (finish shared-secret exchange-hash hash-alg conn)))))] + (transition + (oneshot-handler conn + SSH_MSG_KEXDH_INIT + (lambda (packet message conn) + (define e (ssh-msg-kexdh-init-e message)) + (define e-width (mpint-width e)) + (define e-as-bytes (integer->bit-string e (* 8 e-width) #t)) + (define shared-secret (compute-key private-key e-as-bytes)) + (define hash-alg sha1) + (define-values (host-key-private host-key-public) + (host-key-algorithm->keys host-key-alg)) + (define host-key-bytes + (pieces->ssh-host-key (public-key->pieces host-key-public))) + (define exchange-hash + (dh-exchange-hash hash-info + host-key-bytes + e + public-key-as-integer + (bit-string->integer shared-secret #t #f))) + (define h-signature (host-key-signature host-key-private + host-key-alg + exchange-hash)) + (sequence-actions (transition conn) + (send-message (outbound-packet + (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes) + public-key-as-integer + (bit-string->bytes h-signature)))) + (lambda (conn) + (finish shared-secret exchange-hash hash-alg conn))))))] [else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Bad key-exchange algorithm ~v" kex-alg)])) @@ -293,31 +295,33 @@ dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2 (define-values (private-key public-key) (generate-key group)) (define public-key-as-integer (bit-string->integer public-key #t #f)) - (sequence-actions conn + (sequence-actions (transition conn) (send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))) (lambda (conn) - (oneshot-handler conn - SSH_MSG_KEXDH_REPLY - (lambda (packet message conn) - (define f (ssh-msg-kexdh-reply-f message)) - (define f-width (mpint-width f)) - (define f-as-bytes (integer->bit-string f (* 8 f-width) #t)) - (define shared-secret (compute-key private-key f-as-bytes)) - (define hash-alg sha1) - (define host-key-bytes (ssh-msg-kexdh-reply-host-key message)) - (define host-public-key - (pieces->public-key (ssh-host-key->pieces host-key-bytes))) - (define exchange-hash - (dh-exchange-hash hash-info - host-key-bytes - public-key-as-integer - f - (bit-string->integer shared-secret #t #f))) - (verify-host-key-signature! host-public-key - host-key-alg - exchange-hash - (ssh-msg-kexdh-reply-h-signature message)) - (finish shared-secret exchange-hash hash-alg conn)))))] + (transition + (oneshot-handler conn + SSH_MSG_KEXDH_REPLY + (lambda (packet message conn) + (define f (ssh-msg-kexdh-reply-f message)) + (define f-width (mpint-width f)) + (define f-as-bytes (integer->bit-string f (* 8 f-width) #t)) + (define shared-secret (compute-key private-key f-as-bytes)) + (define hash-alg sha1) + (define host-key-bytes (ssh-msg-kexdh-reply-host-key message)) + (define host-public-key + (pieces->public-key (ssh-host-key->pieces host-key-bytes))) + (define exchange-hash + (dh-exchange-hash hash-info + host-key-bytes + public-key-as-integer + f + (bit-string->integer shared-secret #t #f))) + (verify-host-key-signature! host-public-key + host-key-alg + exchange-hash + (ssh-msg-kexdh-reply-h-signature + message)) + (finish shared-secret exchange-hash hash-alg conn))))))] [else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Bad key-exchange algorithm ~v" kex-alg)])) @@ -409,41 +413,42 @@ (extend (bytes-append key (hash-alg (bit-string->bytes (bit-string (k-h-prefix :: binary) (key :: binary)))))))))) - (oneshot-handler (struct-copy connection conn - [session-id session-id]) ;; just in case it changed - SSH_MSG_NEWKEYS - (lambda (newkeys-packet newkeys-message conn) - ;; First, send our SSH_MSG_NEWKEYS, - ;; incrementing the various counters, and then - ;; apply the new algorithms. Also arm our rekey - ;; timer. - (define new-rekey-state (rekey-in-seconds-or-bytes - (rekey-interval) - (rekey-volume) - (connection-total-transferred conn))) - (transition - (set-handlers (struct-copy connection conn [rekey-state new-rekey-state]) - SSH_MSG_SERVICE_REQUEST handle-msg-service-request) - (send-message (outbound-packet (ssh-msg-newkeys))) - (send-message - (new-keys (connection-is-server? conn) - derive-key - c2s-enc s2c-enc - c2s-mac s2c-mac - c2s-zip s2c-zip)) - (send-message (set-timer 'rekey-timer - (* (rekey-wait-deadline new-rekey-state) 1000) - 'absolute)))))) + (transition + (oneshot-handler (struct-copy connection conn + [session-id session-id]) ;; just in case it changed + SSH_MSG_NEWKEYS + (lambda (newkeys-packet newkeys-message conn) + ;; First, send our SSH_MSG_NEWKEYS, + ;; incrementing the various counters, and then + ;; apply the new algorithms. Also arm our rekey + ;; timer. + (define new-rekey-state (rekey-in-seconds-or-bytes + (rekey-interval) + (rekey-volume) + (connection-total-transferred conn))) + (transition + (set-handlers + (struct-copy connection conn [rekey-state new-rekey-state]) + SSH_MSG_SERVICE_REQUEST handle-msg-service-request) + (send-message (outbound-packet (ssh-msg-newkeys))) + (send-message + (new-keys (connection-is-server? conn) + derive-key + c2s-enc s2c-enc + c2s-mac s2c-mac + c2s-zip s2c-zip)) + (send-message (set-timer 'rekey-timer + (* (rekey-wait-deadline new-rekey-state) 1000) + 'absolute))))))) - (let ((t (if should-discard-first-kex-packet - (struct-copy connection (continue-after-discard conn) [discard-next-packet? #t]) - (continue-after-discard conn)))) - (sequence-actions t - (lambda (conn) - (if (rekey-wait? (connection-rekey-state conn)) - (transition (struct-copy connection conn [rekey-state (rekey-local local-algs)]) - (send-message (outbound-packet local-algs))) - conn))))) + (sequence-actions (continue-after-discard conn) + (when should-discard-first-kex-packet + (lambda (conn) (transition (struct-copy connection conn [discard-next-packet? #t])))) + (lambda (conn) + (if (rekey-wait? (connection-rekey-state conn)) + (transition (struct-copy connection conn [rekey-state (rekey-local local-algs)]) + (send-message (outbound-packet local-algs))) + (transition conn))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Service request manager @@ -456,11 +461,12 @@ (if (connection-authentication-state conn) (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE "Repeated authentication is not permitted") - (sequence-actions conn + (sequence-actions (transition conn) (send-message (outbound-packet (ssh-msg-service-accept service))) - (lambda (conn) (oneshot-handler conn - SSH_MSG_USERAUTH_REQUEST - handle-msg-userauth-request))))] + (lambda (conn) (transition + (oneshot-handler conn + SSH_MSG_USERAUTH_REQUEST + handle-msg-userauth-request)))))] [else (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE "Service ~v not supported" @@ -477,7 +483,7 @@ [(and (positive? (bytes-length user-name)) (equal? service-name #"ssh-connection")) ;; TODO: Actually implement client authentication - (sequence-actions conn + (sequence-actions (transition conn) (send-message (outbound-packet (ssh-msg-userauth-success))) (lambda (conn) (start-connection-service @@ -594,7 +600,7 @@ (list (delete-role (list cname 'outbound)) (delete-role (list cname 'inbound)))] [else (list)])])))] - [else conn])) + [else (transition conn)])) (define (channel-roles cname initial-message-producer) (define inbound-stream-name (channel-stream-name #t cname)) @@ -605,11 +611,9 @@ (role (topic-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) + #:on-presence (transition conn + (initial-message-producer inbound-stream-name outbound-stream-name)) + #:on-absence (maybe-close-channel cname conn 'local) [(channel-message _ body) (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) (define remote-ref (ssh-channel-remote-ref ch)) @@ -672,19 +676,20 @@ (define arbitrary-locally-originated-traffic (channel-message arbitrary-locally-originated-stream (wild))) (sequence-actions - (set-handlers conn - ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request - SSH_MSG_CHANNEL_OPEN handle-msg-channel-open - SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation - SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure - SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust - SSH_MSG_CHANNEL_DATA handle-msg-channel-data - SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data - SSH_MSG_CHANNEL_EOF handle-msg-channel-eof - SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close - SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request - SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success - SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure) + (transition + (set-handlers conn + ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request + SSH_MSG_CHANNEL_OPEN handle-msg-channel-open + SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation + SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure + SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust + SSH_MSG_CHANNEL_DATA handle-msg-channel-data + SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data + SSH_MSG_CHANNEL_EOF handle-msg-channel-eof + SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close + SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request + SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success + SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure)) ;; Start responding to channel interest coming from the ;; application. We are responding to channels appearing from the ;; remote peer by virtue of our installation of the handler for @@ -702,7 +707,7 @@ (transition (update-channel cname values conn) (channel-roles cname (lambda (inbound-stream outbound-stream) '()))) - conn)])))) + (transition conn))])))) (define (handle-msg-channel-open packet message conn) (match-define (ssh-msg-channel-open channel-type* @@ -766,7 +771,7 @@ (define ch (get-channel conn local-ref)) (define description (bit-string->bytes description*)) (define inbound-stream (channel-stream-name #t (ssh-channel-name ch))) - (sequence-actions conn + (sequence-actions (transition conn) (send-message (channel-message inbound-stream (channel-stream-open-failure reason description))) (lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote)))) @@ -828,8 +833,9 @@ "Not authenticated")))) (define ((bump-total amount) conn) - (struct-copy connection conn - [total-transferred (+ (connection-total-transferred conn) amount)])) + (transition + (struct-copy connection conn + [total-transferred (+ (connection-total-transferred conn) amount)]))) ;; (K V A -> A) A Hash -> A (define (hash-fold fn seed hash) @@ -843,7 +849,7 @@ (let ((algs ((local-algorithm-list)))) (transition (struct-copy connection conn [rekey-state (rekey-local algs)]) (send-message (outbound-packet algs)))) - conn)) + (transition conn))) ;; PacketDispatcher. Handles the core transport message types. (define base-packet-dispatcher @@ -874,23 +880,23 @@ (role (topic-subscriber (timer-expired 'rekey-timer (wild))) #:state conn [(timer-expired 'rekey-timer now) - (sequence-actions conn + (sequence-actions (transition conn) maybe-rekey)]) (role (topic-subscriber (outbound-byte-credit (wild))) #:state conn [(outbound-byte-credit amount) - (sequence-actions conn + (sequence-actions (transition conn) (bump-total amount) maybe-rekey)]) (role (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild))) #:state conn [(inbound-packet sequence-number payload message transfer-size) - (sequence-actions conn + (sequence-actions (transition conn) (lambda (conn) (if (connection-discard-next-packet? conn) - (struct-copy connection conn [discard-next-packet? #f]) + (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)) diff --git a/ssh-transport.rkt b/ssh-transport.rkt index a479d28..59e8638 100644 --- a/ssh-transport.rkt +++ b/ssh-transport.rkt @@ -385,7 +385,7 @@ (wild) (wild))) #:state state [(? new-keys? nk) - (struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)])]) + (transition (struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)]))]) (role (topic-publisher (inbound-packet (wild) (wild) (wild) (wild)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -438,4 +438,5 @@ (wild) (wild))) #:state state [(? new-keys? nk) - (struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)])]))) + (transition + (struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))