Use sequence-actions.

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
+	  (sequence-actions state
-	  ;; initialise the reader, switching to packet-reading
+	    ;; First, set the incoming mode to bytes.
-	  ;; mode. Finally, spawn the remaining processes and
+	    (at-meta-level (send-tcp-mode remote-addr local-addr 'bytes))
-	  ;; issue the initial credit to the reader.
+	    ;; Then initialise the reader, switching to packet-reading mode.
-	  (extend-transition
+	    (lambda (ignored-state) (ssh-reader local-addr remote-addr))
-	      (prefix-transition (ssh-reader local-addr remote-addr)
+	    ;; Finally, spawn the remaining processes and issue the initial credit to the reader.
-		(at-meta-level (send-tcp-mode remote-addr local-addr 'bytes)))
 	    (spawn (ssh-writer local-addr remote-addr)
 		   #:monitor? #t
 		   #:debug-name 'ssh-writer)
-	    ;; Wait for a cycle to let the reader and writer get
+	    ;; (Wait for a cycle to let the reader and writer get
-	    ;; started, then tell the reader we are ready for a
+	    ;; started, then tell the reader we are ready for a single
-	    ;; single packet and spawn the session manager.
+	    ;; packet and spawn the session manager.)
-
 	    ;; TODO: try using presence instead of the yield.
 	    (yield #:state state
 	      (transition state

ssh-session.rkt

@@ -119,22 +119,20 @@
 		  (hash-remove d packet-type-number)))
 	    (cddr key-value-pairs))))))
 
-;; Transition [ Byte Maybe<PacketHandler> ]* -> ConnectionState
+;; ConnectionState [ Byte Maybe<PacketHandler> ]* -> ConnectionState
 ;; Installs (or removes) PacketHandlers in the given connection state;
 ;; see extend-packet-dispatcher.
-(define (set-handlers t . key-value-pairs)
+(define (set-handlers conn . key-value-pairs)
-  (extend-transition* t
+  (struct-copy connection conn
-    (lambda (conn)
+	       [dispatch-table (apply extend-packet-dispatcher
-      (struct-copy connection conn
+				      (connection-dispatch-table conn)
-		   [dispatch-table (apply extend-packet-dispatcher
+				      key-value-pairs)]))
-					  (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)
+(define (oneshot-handler conn packet-type-number packet-handler)
-  (set-handlers t
+  (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)))
+			    (finish shared-secret exchange-hash hash-alg conn)))))]
-       (send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))))]
     [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
+	 (sequence-actions conn
-					     SSH_MSG_USERAUTH_REQUEST
+	   (send-message (outbound-packet (ssh-msg-service-accept service)))
-					     handle-msg-userauth-request)
+	   (lambda (conn) (oneshot-handler conn
-	   (send-message (outbound-packet (ssh-msg-service-accept service)))))]
+					   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)))
+			 conn)))))]
-      (send-message (outbound-packet (ssh-msg-userauth-success))))]
    [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)
+(define ((bump-total amount) conn)
-  (extend-transition* t
+  (struct-copy connection conn
-    (lambda (conn)
+	       [total-transferred (+ (connection-total-transferred conn) amount)]))
-      (struct-copy connection conn
-		   [total-transferred (+ (connection-total-transferred conn) amount)]))))
 
 ;; (K V A -> A) A Hash<K,V> -> 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)
+(define (maybe-rekey conn)
-  (extend-transition* t
+  (define rekey (connection-rekey-state conn))
-    (lambda (conn)
+  (if (time-to-rekey? rekey conn)
-      (define rekey (connection-rekey-state conn))
+      (let ((algs ((local-algorithm-list))))
-      (if (time-to-rekey? rekey conn)
+	(transition (struct-copy connection conn [rekey-state (rekey-local algs)])
-	  (let ((algs ((local-algorithm-list))))
+	  (send-message (outbound-packet algs))))
-	    (transition (struct-copy connection conn [rekey-state (rekey-local algs)])
+      conn))
-	      (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)
+  (boot-specification
-    (transition (connection #f
+   (lambda (self-pid)
-			    base-packet-dispatcher
+     (transition (connection #f
-			    0
+			     base-packet-dispatcher
-			    (rekey-in-seconds-or-bytes -1 -1 0)
+			     0
-			    #f
+			     (rekey-in-seconds-or-bytes -1 -1 0)
-			    '()
+			     #f
-			    (case session-role ((client) #f) ((server) #t))
+			     '()
-			    local-identification-string
+			     (case session-role ((client) #f) ((server) #t))
-			    peer-identification-string
+			     local-identification-string
-			    #f)
+			     peer-identification-string
+			     #f)
 
-      (spawn (nested-vm 'ssh-application-vm application-boot)
+       (spawn (nested-vm 'ssh-application-vm application-boot)
-	     #:monitor? #t
+	      #:monitor? #t
-	     #:debug-name 'ssh-application-vm)
+	      #:debug-name 'ssh-application-vm)
 
-      (role 'rekey-waiter (topic-subscriber (timer-expired 'rekey-timer (wild)))
+       (role 'rekey-waiter (topic-subscriber (timer-expired 'rekey-timer (wild)))
-	#:state conn
+	 #:state conn
-	[(timer-expired 'rekey-timer now)
+	 [(timer-expired 'rekey-timer now)
-	 (rekey-wrap conn)])
+	  (sequence-actions conn
+	    maybe-rekey)])
 
-      (role 'credit-listener (topic-subscriber (outbound-byte-credit (wild)))
+       (role 'credit-listener (topic-subscriber (outbound-byte-credit (wild)))
-	#:state conn
+	 #:state conn
-	[(outbound-byte-credit amount)
+	 [(outbound-byte-credit amount)
-	 (rekey-wrap (bump-total conn amount))])
+	  (sequence-actions conn
+	    (bump-total amount)
+	    maybe-rekey)])
 
-      (role 'packet-listener (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
+       (role 'packet-listener (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
-	#:state conn
+	 #:state conn
-	[(inbound-packet sequence-number payload message transfer-size)
+	 [(inbound-packet sequence-number payload message transfer-size)
-	 (let* ((t (if (connection-discard-next-packet? conn)
+	  (sequence-actions conn
-		       (struct-copy connection conn [discard-next-packet? #f])
+	    (lambda (conn)
-		       (dispatch-packet sequence-number payload message conn)))
+	      (if (connection-discard-next-packet? conn)
-		(t (bump-total t transfer-size))
+		  (struct-copy connection conn [discard-next-packet? #f])
-		(t (extend-transition t (send-message (inbound-credit 1)))))
+		  (dispatch-packet sequence-number payload message conn)))
-	   (rekey-wrap t))]))))
+	    (bump-total transfer-size)
+	    (send-message (inbound-credit 1))
+	    maybe-rekey)])))
+   connection?))