diff --git a/new-server.rkt b/new-server.rkt index 2a44460..ae0ae60 100644 --- a/new-server.rkt +++ b/new-server.rkt @@ -147,20 +147,18 @@ (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))) + (sequence-actions state + ;; First, set the incoming mode to bytes. + (at-meta-level (send-tcp-mode remote-addr local-addr 'bytes)) + ;; Then initialise the reader, switching to packet-reading mode. + (lambda (ignored-state) (ssh-reader local-addr remote-addr)) + ;; Finally, spawn the remaining processes and issue the initial credit to the reader. (spawn (ssh-writer local-addr remote-addr) #:monitor? #t #: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. - + ;; (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.) ;; TODO: try using presence instead of the yield. (yield #:state state (transition state diff --git a/ssh-session.rkt b/ssh-session.rkt index a319692..72e254f 100644 --- a/ssh-session.rkt +++ b/ssh-session.rkt @@ -119,22 +119,20 @@ (hash-remove d packet-type-number))) (cddr key-value-pairs)))))) -;; Transition [ Byte Maybe ]* -> ConnectionState +;; ConnectionState [ Byte Maybe ]* -> ConnectionState ;; Installs (or removes) PacketHandlers in the given connection state; ;; see extend-packet-dispatcher. -(define (set-handlers t . key-value-pairs) - (extend-transition* t - (lambda (conn) - (struct-copy connection conn - [dispatch-table (apply extend-packet-dispatcher - (connection-dispatch-table conn) - key-value-pairs)])))) +(define (set-handlers conn . key-value-pairs) + (struct-copy connection conn + [dispatch-table (apply extend-packet-dispatcher + (connection-dispatch-table conn) + key-value-pairs)])) ;; Transition Byte PacketHandler -> ConnectionState ;; Installs a PacketHandler that removes the installed dispatch entry ;; and then delegates to its argument. -(define (oneshot-handler t packet-type-number packet-handler) - (set-handlers t +(define (oneshot-handler conn packet-type-number packet-handler) + (set-handlers conn packet-type-number (lambda (packet message conn) (packet-handler packet @@ -273,11 +271,12 @@ (define h-signature (host-key-signature host-key-private host-key-alg exchange-hash)) - (prefix-transition (finish shared-secret exchange-hash hash-alg conn) + (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)))))))] + (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,7 +292,9 @@ 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)) - (prefix-transition + (sequence-actions 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) @@ -315,8 +316,7 @@ host-key-alg exchange-hash (ssh-msg-kexdh-reply-h-signature message)) - (finish shared-secret exchange-hash hash-alg conn))) - (send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))))] + (finish shared-secret exchange-hash hash-alg conn)))))] [else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Bad key-exchange algorithm ~v" kex-alg)])) @@ -437,7 +437,7 @@ (let ((t (if should-discard-first-kex-packet (struct-copy connection (continue-after-discard conn) [discard-next-packet? #t]) (continue-after-discard conn)))) - (prefix-transition* t + (sequence-actions t (lambda (conn) (if (rekey-wait? (connection-rekey-state conn)) (transition (struct-copy connection conn [rekey-state (rekey-local local-algs)]) @@ -455,10 +455,11 @@ (if (connection-authentication-state conn) (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE "Repeated authentication is not permitted") - (prefix-transition (oneshot-handler conn - SSH_MSG_USERAUTH_REQUEST - handle-msg-userauth-request) - (send-message (outbound-packet (ssh-msg-service-accept service)))))] + (sequence-actions conn + (send-message (outbound-packet (ssh-msg-service-accept service))) + (lambda (conn) (oneshot-handler conn + SSH_MSG_USERAUTH_REQUEST + handle-msg-userauth-request))))] [else (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE "Service ~v not supported" @@ -475,15 +476,16 @@ [(and (positive? (bytes-length user-name)) (equal? service-name #"ssh-connection")) ;; TODO: Actually implement client authentication - (prefix-transition + (sequence-actions conn + (send-message (outbound-packet (ssh-msg-userauth-success))) + (lambda (conn) (start-connection-service (set-handlers (struct-copy connection conn [authentication-state (authenticated user-name service-name)]) SSH_MSG_USERAUTH_REQUEST (lambda (packet message conn) ;; RFC4252 section 5.1 page 6 - conn))) - (send-message (outbound-packet (ssh-msg-userauth-success))))] + conn)))))] [else (transition conn (send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))])) @@ -660,7 +662,7 @@ (channel-stream-name (wild) (channel-name #t (wild) (wild)))) (define arbitrary-locally-originated-traffic (channel-message arbitrary-locally-originated-stream (wild))) - (extend-transition + (sequence-actions (set-handlers conn ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request SSH_MSG_CHANNEL_OPEN handle-msg-channel-open @@ -764,9 +766,10 @@ (define ch (get-channel conn local-ref)) (define description (bit-string->bytes description*)) (define inbound-stream (channel-stream-name #t (ssh-channel-name ch))) - (prefix-transition (maybe-close-channel (ssh-channel-name ch) conn 'remote) + (sequence-actions conn (send-message (channel-message inbound-stream - (channel-stream-open-failure reason description))))) + (channel-stream-open-failure reason description))) + (lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote)))) (define (handle-msg-channel-window-adjust packet message conn) (match-define (ssh-msg-channel-window-adjust local-ref count) message) @@ -824,11 +827,9 @@ (else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR "Not authenticated")))) -(define (bump-total t amount) - (extend-transition* t - (lambda (conn) - (struct-copy connection conn - [total-transferred (+ (connection-total-transferred conn) amount)])))) +(define ((bump-total amount) conn) + (struct-copy connection conn + [total-transferred (+ (connection-total-transferred conn) amount)])) ;; (K V A -> A) A Hash -> A (define (hash-fold fn seed hash) @@ -836,15 +837,13 @@ (seed seed (fn (hash-iterate-key hash pos) (hash-iterate-value hash pos) seed))) ((not pos) seed))) -(define (rekey-wrap t) - (extend-transition* t - (lambda (conn) - (define rekey (connection-rekey-state conn)) - (if (time-to-rekey? rekey conn) - (let ((algs ((local-algorithm-list)))) - (transition (struct-copy connection conn [rekey-state (rekey-local algs)]) - (send-message (outbound-packet algs)))) - conn)))) +(define (maybe-rekey conn) + (define rekey (connection-rekey-state conn)) + (if (time-to-rekey? rekey conn) + (let ((algs ((local-algorithm-list)))) + (transition (struct-copy connection conn [rekey-state (rekey-local algs)]) + (send-message (outbound-packet algs)))) + conn)) ;; PacketDispatcher. Handles the core transport message types. (define base-packet-dispatcher @@ -858,38 +857,45 @@ peer-identification-string application-boot session-role) - (lambda (self-pid) - (transition (connection #f - base-packet-dispatcher - 0 - (rekey-in-seconds-or-bytes -1 -1 0) - #f - '() - (case session-role ((client) #f) ((server) #t)) - local-identification-string - peer-identification-string - #f) + (boot-specification + (lambda (self-pid) + (transition (connection #f + base-packet-dispatcher + 0 + (rekey-in-seconds-or-bytes -1 -1 0) + #f + '() + (case session-role ((client) #f) ((server) #t)) + local-identification-string + peer-identification-string + #f) - (spawn (nested-vm 'ssh-application-vm application-boot) - #:monitor? #t - #:debug-name 'ssh-application-vm) + (spawn (nested-vm 'ssh-application-vm application-boot) + #:monitor? #t + #:debug-name 'ssh-application-vm) - (role 'rekey-waiter (topic-subscriber (timer-expired 'rekey-timer (wild))) - #:state conn - [(timer-expired 'rekey-timer now) - (rekey-wrap conn)]) + (role 'rekey-waiter (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))) - #:state conn - [(outbound-byte-credit amount) - (rekey-wrap (bump-total conn amount))]) + (role 'credit-listener (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))) - #:state conn - [(inbound-packet sequence-number payload message transfer-size) - (let* ((t (if (connection-discard-next-packet? conn) - (struct-copy connection conn [discard-next-packet? #f]) - (dispatch-packet sequence-number payload message conn))) - (t (bump-total t transfer-size)) - (t (extend-transition t (send-message (inbound-credit 1))))) - (rekey-wrap t))])))) + (role 'packet-listener (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild))) + #:state conn + [(inbound-packet sequence-number payload message transfer-size) + (sequence-actions conn + (lambda (conn) + (if (connection-discard-next-packet? conn) + (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)]))) + connection?))