Simple makefile

role names from apps. Make nested-vm a macro.

Makefile

@@ -0,0 +1,5 @@
+all:
+	raco make new-server.rkt
+
+clean:
+	find . -name compiled -type d | xargs rm -rf

OLD-session.rkt

@@ -0,0 +1,941 @@
+#lang racket/base
+
+(require (planet tonyg/bitsyntax))
+(require (planet vyzo/crypto:2:3))
+
+(require racket/match)
+(require racket/class)
+(require racket/port)
+
+(require "safe-io.rkt")
+(require "oakley-groups.rkt")
+
+(require "ssh-host-key.rkt")
+
+(require "functional-queue.rkt")
+(require "conversation.rkt")
+(require "standard-thread.rkt")
+(require "ordered-rpc.rkt")
+
+(require "ssh-numbers.rkt")
+(require "ssh-message-types.rkt")
+(require "ssh-exceptions.rkt")
+(require "ssh-transport.rkt")
+
+(provide required-peer-identification-regex
+	 client-preamble-lines
+	 client-identification-string
+	 rekey-interval
+	 rekey-volume
+
+	 ssh-session)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data definitions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; A RekeyState is one of
+;; - a (rekey-wait Number Number), representing a time or
+;;   transfer-amount by which rekeying should be started
+;; - a (rekey-local SshMsgKexinit), when we've sent our local
+;;   algorithm list and are waiting for the other party to send theirs
+;; - a (rekey-in-progress KeyExchangeState), when both our local
+;;   algorithm list has been sent and the remote one has arrived and the
+;;   actual key exchange has begun
+(struct rekey-wait (deadline threshold-bytes) #:transparent)
+(struct rekey-local (local-algorithms) #:transparent)
+(struct rekey-in-progress (state) #:transparent)
+
+;; An AuthenticationState is one of
+;; - #f, for not-yet-authenticated
+;; - an (authenticated String String), recording successful completion
+;;   of the authentication protocol after a request to be identified
+;;   as the given username for the given service.
+;; TODO: When authentication is properly implemented, we will need
+;; intermediate states here too.
+(struct authenticated (username service) #:transparent)
+
+;; A PacketDispatcher is a Hashtable mapping Byte to PacketHandler.
+
+;; A PacketHandler is a (Bytes DecodedPacket ConnectionState -> ConnectionState).
+;; The raw received bytes of the packet are given because sometimes
+;; cryptographic operations on the received bytes are mandated by the
+;; protocol.
+
+;; A ConnectionState is a (connection StreamState StreamState
+;; PacketDispatcher ... TODO fix this) representing the complete state
+;; of the SSH transport, authentication, and connection layers.
+(struct connection (io-room-handle
+		    session-room-handle
+		    discard-next-packet?
+		    dispatch-table
+		    total-transferred
+		    rekey-state
+		    authentication-state
+		    continuations
+		    channel-map
+		    is-server?
+		    local-id
+		    remote-id
+		    session-id) ;; starts off #f until initial keying
+	#:transparent)
+
+;; A CloseState is one of
+;; - 'neither, indicating that neither side has signalled closure
+;; - 'local, only the local end has signalled closure
+;; - 'remote, only the remote end has signalled closure
+;; - 'both, both ends have signalled closure.
+;; Represents local knowledge of the state of a shared shutdown state
+;; machine.
+;;
+;;                'neither
+;;                /       \
+;;              \/         \/
+;;           'local      'remote
+;;               \         /
+;;                \/     \/
+;;                  'both
+
+;; A ChannelState is a (ssh-channel ...) TODO
+;; Named ssh-channel to avoid conflicts with Racket's built-in
+;; synchronous channels.
+(struct ssh-channel (room-handle ;; RoomHandle
+		     my-ref ;; Uint32
+		     your-ref ;; Maybe<Uint32>
+		     type ;; String
+		     continuations ;; TransactionManager (see ordered-rpc.rkt)
+		     outbound-window ;; Maybe<Natural>
+		     outbound-packet-size ;; Maybe<Natural>
+		     inbound-window ;; Natural
+		     eof-state ;; CloseState covering EOF signals
+		     close-state ;; CloseState covering CLOSE signals
+		     )
+	#:transparent)
+
+;; Generic inputs into the exchange-hash part of key
+;; exchange. Diffie-Hellman uses these fields along with the host key,
+;; the exchange values, and the shared secret to get the final hash.
+(struct exchange-hash-info (client-id
+			    server-id
+			    client-kexinit-bytes
+			    server-kexinit-bytes)
+	#:transparent)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parameters
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define identification-recogniser #rx"^SSH-")
+(define (identification-line? str)
+  (regexp-match identification-recogniser str))
+
+(define required-peer-identification-regex (make-parameter #rx"^SSH-2\\.0-.*"))
+
+(define client-preamble-lines (make-parameter '()))
+(define client-identification-string (make-parameter "SSH-2.0-RacketSSH_0.0"))
+
+(define rekey-interval (make-parameter 3600))
+(define rekey-volume (make-parameter 1000000000))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Packet dispatch and handling
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Bytes -> Byte
+;; Retrieves the packet type byte from a packet.
+(define (encoded-packet-msg-type encoded-packet)
+  (bytes-ref encoded-packet 0))
+
+;; PacketDispatcher [ Byte Maybe<PacketHandler> ]* -> PacketDispatcher
+;; Adds or removes handlers to or from the given PacketDispatcher.
+(define (extend-packet-dispatcher core-dispatcher . key-value-pairs)
+  (let loop ((d core-dispatcher)
+	     (key-value-pairs key-value-pairs))
+    (cond
+     ((null? key-value-pairs)
+      d)
+     ((null? (cdr key-value-pairs))
+      (error 'extend-packet-dispatcher
+	     "Must call extend-packet-dispatcher with matched key/value pairs"))
+     (else
+      (loop (let ((packet-type-number (car key-value-pairs))
+		  (packet-handler-or-false (cadr key-value-pairs)))
+	      (if packet-handler-or-false
+		  (hash-set d packet-type-number packet-handler-or-false)
+		  (hash-remove d packet-type-number)))
+	    (cddr key-value-pairs))))))
+
+;; ConnectionState [ Byte Maybe<PacketHandler> ]* -> ConnectionState
+;; Installs (or removes) PacketHandlers in the given connection state;
+;; see extend-packet-dispatcher.
+(define (set-handlers conn . key-value-pairs)
+  (struct-copy connection conn
+	       [dispatch-table (apply extend-packet-dispatcher
+				      (connection-dispatch-table conn)
+				      key-value-pairs)]))
+
+;; ConnectionState Byte PacketHandler -> ConnectionState
+;; Installs a PacketHandler that removes the installed dispatch entry
+;; and then delegates to its argument.
+(define (oneshot-handler conn packet-type-number packet-handler)
+  (set-handlers conn
+		packet-type-number
+		(lambda (packet message conn)
+		  (packet-handler packet
+				  message
+				  (set-handlers conn packet-type-number #f)))))
+
+(define (dispatch-packet seq packet message conn)
+  (define packet-type-number (encoded-packet-msg-type packet))
+  (if (and (not (rekey-wait? (connection-rekey-state conn)))
+	   (or (not (ssh-msg-type-transport-layer? packet-type-number))
+	       (= packet-type-number SSH_MSG_SERVICE_REQUEST)
+	       (= packet-type-number SSH_MSG_SERVICE_ACCEPT)))
+      ;; We're in the middle of some phase of an active key-exchange,
+      ;; and received a packet that's for a higher layer than the
+      ;; transport layer, or one of the forbidden types given at the
+      ;; send of RFC4253 section 7.1.
+      (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
+			     "Packets of type ~v forbidden while in key-exchange"
+			     packet-type-number)
+      ;; We're either idling, or it's a permitted packet type while
+      ;; performing key exchange. Look it up in the dispatch table.
+      (let ((handler (hash-ref (connection-dispatch-table conn)
+			       packet-type-number
+			       #f)))
+	(if handler
+	    (handler packet message conn)
+	    (begin (write-message!/flush (ssh-msg-unimplemented seq) conn)
+		   conn)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Handlers for core transport packet types
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; PacketHandler for handling SSH_MSG_DISCONNECT.
+(define (handle-msg-disconnect packet message conn)
+  (disconnect-with-error* #t
+			  '()
+			  (ssh-msg-disconnect-reason-code message)
+			  "Received SSH_MSG_DISCONNECT with reason code ~a and message ~s"
+			  (ssh-msg-disconnect-reason-code message)
+			  (bytes->string/utf-8 (bit-string->bytes
+						(ssh-msg-disconnect-description message)))))
+
+;; PacketHandler for handling SSH_MSG_IGNORE.
+(define (handle-msg-ignore packet message conn)
+  conn)
+
+;; PacketHandler for handling SSH_MSG_UNIMPLEMENTED.
+(define (handle-msg-unimplemented packet message conn)
+  (disconnect-with-error/local-info
+   `((offending-sequence-number ,(ssh-msg-unimplemented-sequence-number message)))
+   SSH_DISCONNECT_PROTOCOL_ERROR
+   "Disconnecting because of received SSH_MSG_UNIMPLEMENTED."))
+
+;; 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)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Key Exchange
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (rekey-in-seconds-or-bytes delta-seconds delta-bytes total-transferred)
+  (rekey-wait (+ (current-seconds) delta-seconds)
+	      (+ total-transferred delta-bytes)))
+
+(define (time-to-rekey? rekey conn)
+  (and (rekey-wait? rekey)
+       (or (>= (current-seconds) (rekey-wait-deadline rekey))
+	   (>= (connection-total-transferred conn) (rekey-wait-threshold-bytes rekey)))))
+
+;; (SshMsgKexinit -> Symbol) SshMsgKexinit SshMsgKexinit -> Symbol
+;; Computes the name of the "best" algorithm choice at the given
+;; getter, using the rules from the RFC and the client and server
+;; algorithm precedence lists.
+(define (best-result getter client-algs server-algs)
+  (define client-list0 (getter client-algs))
+  (define server-list (getter server-algs))
+  (let loop ((client-list client-list0))
+    (cond
+     ((null? client-list) (disconnect-with-error/local-info
+			   `((client-list ,client-list0)
+			     (server-list ,server-list))
+			   SSH_DISCONNECT_KEY_EXCHANGE_FAILED
+			   "Could not agree on a suitable algorithm for ~v"
+			   getter))
+     ((memq (car client-list) server-list) (car client-list))
+     (else (loop (cdr client-list))))))
+
+;; ExchangeHashInfo Bytes Natural Natural Natural -> Bytes
+;; Computes the session ID as defined by SSH's DH key exchange method.
+(define (dh-exchange-hash hash-info host-key e f k)
+  (let ((block-to-hash
+	 (bit-string->bytes
+	  (bit-string ((string->bytes/utf-8 (exchange-hash-info-client-id hash-info)) :: (t:string))
+		      ((string->bytes/utf-8 (exchange-hash-info-server-id hash-info)) :: (t:string))
+		      ((exchange-hash-info-client-kexinit-bytes hash-info) :: (t:string))
+		      ((exchange-hash-info-server-kexinit-bytes hash-info) :: (t:string))
+		      (host-key :: (t:string))
+		      (e :: (t:mpint))
+		      (f :: (t:mpint))
+		      (k :: (t:mpint))))))
+    (sha1 block-to-hash)))
+
+;; ExchangeHashInfo Symbol Symbol ConnectionState
+;;   (Bytes Bytes Symbol ConnectionState -> ConnectionState)
+;;   -> ConnectionState
+;; Performs the server's half of the Diffie-Hellman key exchange protocol.
+(define (perform-server-key-exchange hash-info kex-alg host-key-alg conn finish)
+  (case kex-alg
+    ((diffie-hellman-group14-sha1 diffie-hellman-group1-sha1)
+     (define group (if (eq? kex-alg 'diffie-hellman-group14-sha1)
+		       dh:oakley-group-14
+		       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))
+			(write-message!/flush (ssh-msg-kexdh-reply host-key-bytes
+								   public-key-as-integer
+								   h-signature)
+					      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))))
+
+;; ExchangeHashInfo Symbol Symbol ConnectionState
+;;   (Bytes Bytes Symbol ConnectionState -> ConnectionState)
+;;   -> ConnectionState
+;; Performs the client's half of the Diffie-Hellman key exchange protocol.
+(define (perform-client-key-exchange hash-info kex-alg host-key-alg conn finish)
+  (case kex-alg
+    ((diffie-hellman-group14-sha1 diffie-hellman-group1-sha1)
+     (define group (if (eq? kex-alg 'diffie-hellman-group14-sha1)
+		       dh:oakley-group-14
+		       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))
+     (write-message!/flush (ssh-msg-kexdh-init public-key-as-integer) 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))))
+    (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
+				 "Bad key-exchange algorithm ~v" kex-alg))))
+
+;; PacketHandler for handling SSH_MSG_KEXINIT.
+(define (handle-msg-kexinit packet message conn)
+  (define rekey (connection-rekey-state conn))
+  (when (rekey-in-progress? rekey)
+    (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
+			   "Received SSH_MSG_KEXINIT during ongoing key exchange"))
+  (define local-algs (if (rekey-local? rekey)
+			 (rekey-local-local-algorithms rekey)
+			 ((local-algorithm-list))))
+  (define encoded-local-algs (ssh-message-encode local-algs))
+  (define remote-algs message)
+  (define encoded-remote-algs packet)
+
+  (when (rekey-wait? rekey)
+    (write-message!/flush local-algs conn))
+
+  (define is-server? (connection-is-server? conn))
+  (define c (if is-server? remote-algs local-algs))
+  (define s (if is-server? local-algs remote-algs))
+
+  (define kex-alg (best-result ssh-msg-kexinit-kex_algorithms c s))
+  (define host-key-alg (best-result ssh-msg-kexinit-server_host_key_algorithms c s))
+  (define c2s-enc (best-result ssh-msg-kexinit-encryption_algorithms_client_to_server c s))
+  (define s2c-enc (best-result ssh-msg-kexinit-encryption_algorithms_server_to_client c s))
+  (define c2s-mac (best-result ssh-msg-kexinit-mac_algorithms_client_to_server c s))
+  (define s2c-mac (best-result ssh-msg-kexinit-mac_algorithms_server_to_client c s))
+  (define c2s-zip (best-result ssh-msg-kexinit-compression_algorithms_client_to_server c s))
+  (define s2c-zip (best-result ssh-msg-kexinit-compression_algorithms_server_to_client c s))
+  ;; Ignore languages.
+  ;; Don't check the reserved field here, either. TODO: should we?
+
+  (define (guess-matches? chosen-value getter)
+    (let ((remote-choices (getter remote-algs)))
+      (and (pair? remote-choices) ;; not strictly necessary because of
+				  ;; the error behaviour of
+				  ;; best-result.
+	   (eq? (car remote-choices) ;; the remote peer's guess for this parameter
+		chosen-value))))
+
+  (define should-discard-first-kex-packet
+    (and (ssh-msg-kexinit-first_kex_packet_follows remote-algs)
+	 ;; They've already transmitted their guess. Does their guess match
+	 ;; what we've actually selected?
+	 (not (and
+	       (guess-matches? kex-alg ssh-msg-kexinit-kex_algorithms)
+	       (guess-matches? host-key-alg ssh-msg-kexinit-server_host_key_algorithms)
+	       (guess-matches? c2s-enc ssh-msg-kexinit-encryption_algorithms_client_to_server)
+	       (guess-matches? s2c-enc ssh-msg-kexinit-encryption_algorithms_server_to_client)
+	       (guess-matches? c2s-mac ssh-msg-kexinit-mac_algorithms_client_to_server)
+	       (guess-matches? s2c-mac ssh-msg-kexinit-mac_algorithms_server_to_client)
+	       (guess-matches? c2s-zip ssh-msg-kexinit-compression_algorithms_client_to_server)
+	       (guess-matches? s2c-zip ssh-msg-kexinit-compression_algorithms_server_to_client)))))
+
+  (define (continue-after-discard conn)
+    ((if is-server?
+	 perform-server-key-exchange
+	 perform-client-key-exchange)
+     (if is-server?
+	 (exchange-hash-info (connection-remote-id conn)
+			     (connection-local-id conn)
+			     encoded-remote-algs
+			     encoded-local-algs)
+	 (exchange-hash-info (connection-local-id conn)
+			     (connection-remote-id conn)
+			     encoded-local-algs
+			     encoded-remote-algs))
+     kex-alg
+     host-key-alg
+     conn
+     continue-after-key-exchange))
+
+  (define (continue-after-key-exchange shared-secret exchange-hash hash-alg conn)
+    (define session-id (if (connection-session-id conn)
+			   (connection-session-id conn) ;; don't overwrite existing ID
+			   exchange-hash))
+    (define k-h-prefix (bit-string ((bit-string->integer shared-secret #t #f) :: (t:mpint))
+				   (exchange-hash :: binary)))
+    (define (derive-key kind needed-bytes-or-false)
+      (let extend ((key (hash-alg (bit-string->bytes
+				   (bit-string (k-h-prefix :: binary)
+					       (kind :: binary)
+					       (session-id :: binary))))))
+	(cond
+	 ((eq? #f needed-bytes-or-false)
+	  key)
+	 ((>= (bytes-length key) needed-bytes-or-false)
+	  (subbytes key 0 needed-bytes-or-false))
+	 (else
+	  (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.
+		       (write-message!/flush (ssh-msg-newkeys) conn)
+		       (send (connection-io-room-handle conn) say
+			     (new-keys (connection-is-server? conn)
+				       derive-key
+				       c2s-enc s2c-enc
+				       c2s-mac s2c-mac
+				       c2s-zip s2c-zip))
+		       (set-handlers (struct-copy connection conn
+						  [rekey-state
+						   (rekey-in-seconds-or-bytes
+						    (rekey-interval)
+						    (rekey-volume)
+						    (connection-total-transferred conn))])
+				     SSH_MSG_SERVICE_REQUEST handle-msg-service-request))))
+
+  (if should-discard-first-kex-packet
+      (struct-copy connection (continue-after-discard conn) [discard-next-packet? #t])
+      (continue-after-discard conn)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Service request manager
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (handle-msg-service-request packet message conn)
+  (define service (bit-string->bytes (ssh-msg-service-request-service-name message)))
+  (match service
+    (#"ssh-userauth"
+     (if (connection-authentication-state conn)
+	 (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
+				"Repeated authentication is not permitted")
+	 (begin
+	   (write-message!/flush (ssh-msg-service-accept service) 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"
+			    service))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; User authentication
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (handle-msg-userauth-request packet message conn)
+  (define user-name (bit-string->bytes (ssh-msg-userauth-request-user-name message)))
+  (define service-name (bit-string->bytes (ssh-msg-userauth-request-service-name message)))
+  (cond
+   ((and (positive? (bytes-length user-name))
+	 (equal? service-name #"ssh-connection"))
+    ;; TODO: Actually implement client authentication
+    (write-message!/flush (ssh-msg-userauth-success) 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))))
+   (else
+    (write-message!/flush (ssh-msg-userauth-failure '(none) #f) conn)
+    conn)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Channel management
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (allocate-channel conn room type your-ref outbound-window outbound-packet-size)
+  (define my-ref (hash-count (connection-channel-map conn)))
+  (define ch (ssh-channel (join-room room 'session)
+			  my-ref
+			  your-ref
+			  type
+			  (make-transaction-manager)
+			  outbound-window
+			  outbound-packet-size
+			  1048576 ;; TODO: parameterize? Make configurable by app?
+			  'neither
+			  'neither
+			  ))
+  (values ch
+	  (struct-copy connection (send-initial-credit conn ch)
+		       [channel-map (hash-set (connection-channel-map conn) my-ref ch)])))
+
+(define (send-initial-credit conn ch)
+  (define remaining-window (ssh-channel-outbound-window ch))
+  (if (and remaining-window
+	   (positive? remaining-window))
+      (channel-notify conn ch (credit 'app remaining-window))
+      conn))
+
+(define (get-channel conn my-ref)
+  (hash-ref (connection-channel-map conn) my-ref))
+
+(define (update-channel conn ch)
+  (struct-copy connection conn
+	       [channel-map (hash-set (connection-channel-map conn) (ssh-channel-my-ref ch) ch)]))
+
+(define (discard-channel ch conn)
+  (struct-copy connection conn
+	       [channel-map (hash-remove (connection-channel-map conn) (ssh-channel-my-ref ch))]))
+
+;; CloseState Either<'local,'remote> -> CloseState
+(define (update-close-state old-state action)
+  (define local? (case action ((local) #t) ((remote) #f)))
+  (case old-state
+    ((neither) (if local? 'local 'remote))
+    ((local) (if local? 'local 'both))
+    ((remote) (if local? 'both 'remote))
+    ((both) 'both)))
+
+(define (maybe-close-channel ch conn action)
+  (define new-close-state (update-close-state (ssh-channel-close-state ch) action))
+  (case action
+    ((local) (write-message!/flush (ssh-msg-channel-close (ssh-channel-your-ref ch))
+				   conn))
+    ((remote) (send (ssh-channel-room-handle ch) depart 'remote-closed)))
+  (if (eq? new-close-state 'both)
+      (discard-channel ch conn)
+      (update-channel conn (struct-copy ssh-channel ch
+					[close-state new-close-state]))))
+
+(define (channel-notify conn ch message)
+  (send (ssh-channel-room-handle ch) say message)
+  conn)
+
+(define (channel-request conn ch message k)
+  (update-channel conn
+		  (struct-copy ssh-channel ch
+			       [continuations (room-rpc (ssh-channel-room-handle ch)
+							(ssh-channel-continuations ch)
+							message
+							k)])))
+
+(define (finish-channel-request ch conn txn message)
+  (define-values (worklist new-continuations)
+    (room-rpc-finish (ssh-channel-continuations ch) txn message))
+  (let loop ((worklist worklist)
+	     (ch (struct-copy ssh-channel ch [continuations new-continuations]))
+	     (conn conn))
+    (if (null? worklist)
+	(update-channel conn ch)
+	(let ((item (car worklist)))
+	  (define-values (new-ch new-conn) (item ch conn))
+	  (loop (cdr worklist) new-ch new-conn)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Connection service
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (start-connection-service conn)
+  (set-handlers conn
+		;; TODO: SSH_MSG_GLOBAL_REQUEST		handle-msg-global-request
+		SSH_MSG_CHANNEL_OPEN		handle-msg-channel-open
+		SSH_MSG_CHANNEL_WINDOW_ADJUST	handle-msg-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))
+
+(define (handle-msg-global-request packet message conn)
+  (log-error "TODO: Unimplemented: handle-msg-global-request")
+  conn)
+
+(define (handle-msg-channel-open packet message conn)
+  (match-define (ssh-msg-channel-open channel-type*
+				      sender-channel
+				      initial-window-size
+				      maximum-packet-size
+				      extra-request-data*)
+		message)
+  (define channel-type (bit-string->bytes channel-type*))
+  (define extra-request-data (bit-string->bytes extra-request-data*))
+  (app-request conn
+	       `(open-channel ,(connection-username conn) ,channel-type ,extra-request-data)
+	       (lambda (reply conn)
+		 (match reply
+		   (`(ok ,(? room? room) ,(? bytes? extra-reply-data))
+		    (let-values (((ch conn) (allocate-channel conn
+							      room
+							      channel-type
+							      sender-channel
+							      initial-window-size
+							      maximum-packet-size)))
+		      (write-message!/flush (ssh-msg-channel-open-confirmation
+					     sender-channel
+					     (ssh-channel-my-ref ch)
+					     (ssh-channel-inbound-window ch)
+					     (default-packet-limit) ;; TODO get from reader
+					     extra-reply-data)
+					    conn)
+		      conn))
+		   (`(error ,reason-code ,description)
+		    (write-message!/flush (ssh-msg-channel-open-failure
+					   sender-channel
+					   reason-code
+					   (string->bytes/utf-8 description)
+					   #"")
+					  conn)
+		    conn)))))
+
+(define (handle-msg-window-adjust packet message conn)
+  (match-define (ssh-msg-channel-window-adjust recipient-channel count) message)
+  (define ch (get-channel conn recipient-channel))
+  (channel-notify conn ch (credit 'app count)))
+
+(define (handle-msg-channel-data packet message conn)
+  (match-define (ssh-msg-channel-data recipient-channel data*) message)
+  (define data (bit-string->bytes data*))
+  (define ch (get-channel conn recipient-channel))
+  (channel-notify conn ch `(data ,data)))
+
+(define (handle-msg-channel-extended-data packet message conn)
+  (match-define (ssh-msg-channel-extended-data recipient-channel type-code data*) message)
+  (define data (bit-string->bytes data*))
+  (define ch (get-channel conn recipient-channel))
+  (channel-notify conn ch `(extended-data ,type-code ,data)))
+
+(define (handle-msg-channel-eof packet message conn)
+  (define ch (get-channel conn (ssh-msg-channel-eof-recipient-channel message)))
+  (update-channel (channel-notify conn ch `(eof))
+		  (struct-copy ssh-channel ch
+			       [eof-state (update-close-state (ssh-channel-eof-state ch)
+							      'remote)])))
+
+(define (handle-msg-channel-close packet message conn)
+  (define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message)))
+  (maybe-close-channel ch conn 'remote))
+
+(define (handle-msg-channel-request packet message conn)
+  (match-define (ssh-msg-channel-request recipient-channel type* want-reply? data*) message)
+  (define type (bit-string->bytes type*))
+  (define data (bit-string->bytes data*))
+  (define ch (get-channel conn recipient-channel))
+  (if (not want-reply?)
+      (channel-notify conn ch `(notify ,type ,data))
+      (channel-request conn ch `(,type ,data)
+		       (lambda (reply ch conn)
+			 (define your-ref (ssh-channel-your-ref ch))
+			 (write-message!/flush (match reply
+						 ('ok (ssh-msg-channel-success your-ref))
+						 ('error (ssh-msg-channel-failure your-ref)))
+					       conn)
+			 (values ch conn)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Session main loop
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (write-message! message conn)
+  (send (connection-io-room-handle conn) say message))
+
+(define (flush-outbound-messages! conn)
+  (send (connection-io-room-handle conn) say 'flush))
+
+(define (write-message!/flush message conn)
+  (write-message! message conn)
+  (flush-outbound-messages! conn))
+
+(define (connection-username conn)
+  (match (connection-authentication-state conn)
+    ((authenticated username servicename)
+     username)
+    (else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
+				 "Not authenticated"))))
+
+(define (app-notify conn message)
+  (send (connection-session-room-handle conn) say message)
+  conn)
+
+(define (app-request conn message k)
+  (struct-copy connection conn
+	       [continuations (room-rpc (connection-session-room-handle conn)
+					(connection-continuations conn)
+					message
+					k)]))
+
+(define (finish-app-request conn txn message)
+  (define-values (worklist new-continuations)
+    (room-rpc-finish (connection-continuations conn) txn message))
+  (foldl (lambda (item conn) (item conn))
+	 (struct-copy connection conn [continuations new-continuations])
+	 worklist))
+
+(define (maybe-send-disconnect-message! e conn)
+  (when (not (exn:fail:contract:protocol-originated-at-peer? e))
+    (write-message!/flush (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code e)
+					      (string->bytes/utf-8 (exn-message e))
+					      #"")
+			  conn)))
+
+(define (bump-total amount conn)
+  (struct-copy connection conn [total-transferred (+ (connection-total-transferred conn) amount)]))
+
+(define io-room-message-handler
+  (lambda (message)
+    (lambda (conn)
+      (match message
+	((arrived 'read-thread)
+	 (send (connection-io-room-handle conn) say (credit 'read-thread 1))
+	 conn)
+	((arrived _)
+	 conn)
+	((and departure (departed who why))
+	 (if (zero? (hash-count (connection-channel-map conn)))
+	     ;; No open or half-open channels. No point in complaining; just leave.
+	     #f
+	     ;; At least one channel. Make more of a noise.
+	     (disconnect-with-error/local-info departure
+					       SSH_DISCONNECT_CONNECTION_LOST
+					       "I/O error")))
+	((says _ amount 'output-byte-count)
+	 ;; writer reporting bytes transferred
+	 (bump-total amount conn))
+	((says _ (received-packet seq packet message transferred-count) _)
+	 (send (connection-io-room-handle conn) say (credit 'read-thread 1))
+	 (bump-total
+	  transferred-count
+	  (if (connection-discard-next-packet? conn)
+	      (struct-copy connection conn [discard-next-packet? #f])
+	      (dispatch-packet seq packet message conn))))))))
+
+(define session-room-message-handler
+  (lambda (message)
+    (lambda (conn)
+      (match message
+	((arrived _)
+	 conn)
+	((and departure (departed _ _))
+	 (disconnect-with-error/local-info
+	  departure
+	  SSH_DISCONNECT_BY_APPLICATION
+	  "Application disconnected"))
+	((says _ (rpc-reply transaction message) _)
+	 ;; TODO: not cap-secure. Introduce sealers, or indirect.
+	 (finish-app-request conn transaction message))))))
+
+;; (K V A -> A) A Hash<K,V> -> A
+(define (hash-fold fn seed hash)
+  (do ((pos (hash-iterate-first hash) (hash-iterate-next hash pos))
+       (seed seed (fn (hash-iterate-key hash pos) (hash-iterate-value hash pos) seed)))
+      ((not pos) seed)))
+
+(define (channel-events conn)
+  (hash-fold (lambda (my-ref ch evt)
+	       (choice-evt evt
+			   (handle-evt (send (ssh-channel-room-handle ch) listen-evt)
+				       (channel-room-message-handler my-ref))))
+	     never-evt
+	     (connection-channel-map conn)))
+
+(define (channel-room-message-handler my-ref)
+  (lambda (message)
+    (lambda (conn)
+      (define ch (get-channel conn my-ref))
+      (define your-ref (ssh-channel-your-ref ch))
+      (match message
+	((arrived _)
+	 conn)
+	((departed _ _)
+	 (maybe-close-channel ch conn 'local))
+	((says _ (credit _ amount) _)
+	 (write-message!/flush (ssh-msg-channel-window-adjust your-ref amount) conn)
+	 conn)
+	((says _ `(data ,bits) _)
+	 (write-message!/flush (ssh-msg-channel-data your-ref bits) conn)
+	 conn)
+	((says _ `(eof) _)
+	 (write-message!/flush (ssh-msg-channel-eof your-ref) conn)
+	 conn)
+	((says _ (rpc-reply id m) _)
+	 (finish-channel-request ch conn id m))))))
+
+(define (run-ssh-session conn)
+  (with-handlers
+      ((exn:fail:contract:protocol? (lambda (e)
+				      (maybe-send-disconnect-message! e conn)
+				      (raise e))))
+    (let loop ((conn conn))
+      (define rekey (connection-rekey-state conn))
+      (if (time-to-rekey? rekey conn)
+	  (let ((algs ((local-algorithm-list))))
+	    (write-message!/flush algs conn)
+	    (loop (struct-copy connection conn [rekey-state (rekey-local algs)])))
+	  (let ((handler (sync (if (rekey-wait? rekey)
+				   (handle-evt (alarm-evt (* (rekey-wait-deadline rekey) 1000))
+					       (lambda (dummy)
+						 (lambda (conn)
+						   conn)))
+				   never-evt)
+			       (handle-evt (send (connection-io-room-handle conn) listen-evt)
+					   io-room-message-handler)
+			       (handle-evt (send (connection-session-room-handle conn) listen-evt)
+					   session-room-message-handler)
+			       (channel-events conn))))
+	    (define new-conn (handler conn))
+	    ;; The handler is permitted to return #f to indicate that the session is to be
+	    ;; gracefully shut down.
+	    (when new-conn
+	      (loop new-conn)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Session choreography
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (send-preamble-and-identification! out)
+  (let ((my-id (client-identification-string)))
+    (for-each (lambda (line)
+		(when (identification-line? line)
+		  (error 'ssh-session
+			 "Client preamble includes forbidden line ~v"
+			 line))
+		(display line out)
+		(display "\r\n" out))
+	      (client-preamble-lines))
+    (display my-id out)
+    (display "\r\n" out)
+    (flush-output out)
+    my-id))
+
+;; Port -> String
+(define (read-preamble-and-identification! in)
+  (let ((line (read-line-limited in 253))) ;; 255 incl CRLF
+    (when (eof-object? line)
+      (error 'ssh-session "EOF while reading connection preamble"))
+    (if (identification-line? line)
+	line
+	(read-preamble-and-identification! in))))
+
+;; PacketDispatcher. Handles the core transport message types.
+(define base-packet-dispatcher
+  (hasheq SSH_MSG_DISCONNECT handle-msg-disconnect
+	  SSH_MSG_IGNORE handle-msg-ignore
+	  SSH_MSG_UNIMPLEMENTED handle-msg-unimplemented
+	  SSH_MSG_DEBUG handle-msg-debug
+	  SSH_MSG_KEXINIT handle-msg-kexinit))
+
+(define (ssh-session role in out)
+  (define io-room (make-room (gensym 'ssh-io-room)))
+  ;;(spy-on io-room)
+  (define session-room (make-room (gensym 'ssh-session-room)))
+  ;;(spy-on session-room)
+
+  (define local-identification-string (send-preamble-and-identification! out))
+  (define peer-identification-string (read-preamble-and-identification! in))
+
+  ;; Each identification string is both a cleartext indicator that
+  ;; we've reached some notion of the right place and also input to
+  ;; the hash function used during D-H key exchange.
+  (when (not (regexp-match (required-peer-identification-regex)
+			   peer-identification-string))
+    (display "Invalid identification\r\n" out)
+    (flush-output out)
+    (error 'ssh-session
+	   "Invalid peer identification string ~v"
+	   peer-identification-string))
+
+  (standard-thread (lambda () (ssh-reader in io-room)))
+  (standard-thread (lambda () (ssh-writer out io-room)))
+  (wait-for-members io-room '(read-thread write-thread))
+  (standard-thread
+   (lambda ()
+     (run-ssh-session (connection (join-room io-room 'session)
+				  (join-room session-room 'session)
+				  #f
+				  base-packet-dispatcher
+				  0
+				  (rekey-in-seconds-or-bytes -1 -1 0)
+				  #f
+				  (make-transaction-manager)
+				  (hash)
+				  (case role ((client) #f) ((server) #t))
+				  local-identification-string
+				  peer-identification-string
+				  #f))))
+
+  (join-room session-room 'app))

asn1-ber.rkt

@@ -15,8 +15,8 @@
 
 (define-syntax t:long-ber-tag
   (syntax-rules ()
-    ((_ #t) read-long-tag)
-    ((_ #f) write-long-tag)))
+    ((_ #t input ks kf) (read-long-tag input ks kf))
+    ((_ #f v) (write-long-tag v))))
 
 (define (read-long-tag input ks kf)
   (let loop ((acc 0)
@@ -51,33 +51,34 @@
 
 (define-syntax t:ber-length-indicator
   (syntax-rules ()
-    ((_ #t) (lambda (input ks kf)
-	      (bit-string-case input
-		([ (= 128 :: bits 8)
-		   (rest :: binary) ]
-		 (ks 'indefinite rest))
-		([ (= 0 :: bits 1)
-		   (len :: bits 7)
-		   (rest :: binary) ]
-		 (ks len rest))
-		([ (= 1 :: bits 1)
-		   (lenlen :: bits 7)
-		   (len :: integer bytes lenlen)
-		   (rest :: binary) ]
-		 (when (not (= lenlen 127))) ;; restriction from section 8.1.3.5
-		 (ks len rest))
-		(else (kf)))))
-    ((_ #f) (lambda (len)
-	      (cond
-	       ((eq? len 'indefinite)
-		(bytes 128))
-	       ((< len 128)
-		(bytes len))
-	       (else
-		(let ((lenlen (quotient (+ 7 (integer-length len)) 8)))
-		  (bit-string (1 :: bits 1)
-			      (lenlen :: bits 7)
-			      (len :: integer bytes lenlen)))))))))
+    ((_ #t input ks0 kf)
+     (let ((ks ks0)) ;; avoid code explosion
+       (bit-string-case input
+	 ([ (= 128 :: bits 8)
+	    (rest :: binary) ]
+	  (ks 'indefinite rest))
+	 ([ (= 0 :: bits 1)
+	    (len :: bits 7)
+	    (rest :: binary) ]
+	  (ks len rest))
+	 ([ (= 1 :: bits 1)
+	    (lenlen :: bits 7)
+	    (len :: integer bytes lenlen)
+	    (rest :: binary) ]
+	  (when (not (= lenlen 127))) ;; restriction from section 8.1.3.5
+	  (ks len rest))
+	 (else (kf)))))
+    ((_ #f len)
+     (cond
+      ((eq? len 'indefinite)
+       (bytes 128))
+      ((< len 128)
+       (bytes len))
+      (else
+       (let ((lenlen (quotient (+ 7 (integer-length len)) 8)))
+	 (bit-string (1 :: bits 1)
+		     (lenlen :: bits 7)
+		     (len :: integer bytes lenlen))))))))
 
 (define (asn1-ber-decode-all packet)
   (let-values (((value rest) (asn1-ber-decode packet)))

conversation-socket.rkt

@@ -1,143 +0,0 @@
-#lang racket/base
-
-(require racket/port)
-(require racket/class)
-(require racket/match)
-(require racket/tcp)
-(require "conversation.rkt")
-
-(provide (struct-out set-options)
-	 tcp-server-actor
-	 tcp-client-actor)
-
-(struct set-options (new-values) #:prefab)
-
-(define (socket-name role s)
-  (define-values (local-ip local-port remote-ip remote-port)
-    (tcp-addresses s #t))
-  (list role local-ip local-port remote-ip remote-port))
-
-(define (option-value options key [missing-value #f])
-  (cond
-   ((assq key options) => cadr)
-   (else missing-value)))
-
-(define (tcp-server-actor room options . tcp-listener-args)
-  (define listener (apply tcp-listen tcp-listener-args))
-  (define name (socket-name 'listener listener))
-  (thread (lambda ()
-	    (define handle (join-room room name))
-	    (log-info (format "Listening on ~v" name))
-	    (let loop ((owner #f)
-		       (remaining-credit (option-value options 'initial-accept-credit 0)))
-	      (sync (handle-evt (send handle disconnected-evt)
-				(lambda (reason)
-				  (log-error (format "~v: conversation closed: ~v" name reason))
-				  (tcp-close listener)))
-		    (handle-evt (send handle listen-evt)
-				(match-lambda
-				 ((arrived who)
-				  (log-info (format "~v: New owner: ~v" name who))
-				  (loop who remaining-credit))
-				 ((departed who why)
-				  (if (equal? owner who)
-				      (begin (log-info (format "~v: Owner departed, closing" name))
-					     (tcp-close listener))
-				      (loop owner remaining-credit)))
-				 ((says _ (credit _ amount) _)
-				  (define new-credit (+ remaining-credit amount))
-				  (log-info (format "~v: Credit now ~v" name new-credit))
-				  (loop owner new-credit))
-				 (unexpected
-				  (log-warning (format "~v: Ignoring message: ~v" name unexpected))
-				  (loop owner remaining-credit))))
-		    (if (positive? remaining-credit)
-			(handle-evt (tcp-accept-evt listener)
-				    (match-lambda
-				     ((list i o)
-				      (send handle say
-					    (tcp-socket-actor 'inbound-connection options i o)
-					    'accepted)
-				      (loop owner (- remaining-credit 1)))))
-			never-evt)))))
-  room)
-
-(define (tcp-client-actor room options . tcp-connect-args)
-  (define-values (i o) (apply tcp-connect tcp-connect-args))
-  (tcp-socket-actor 'outbound-connection options i o))
-
-(define (tcp-socket-actor role options i o [room (make-room)])
-  (define name (socket-name role i))
-  (define (close-ports)
-    (close-input-port i)
-    (close-output-port o))
-  (define (compute-terminator options)
-    ;; See read-line-evt and friends.
-    (option-value options 'line-terminator 'any))
-  (define (compute-read-evt options)
-    (define read-mode (option-value options 'read-mode 'bytes))
-    (case read-mode
-      ((bytes) (values (lambda (credit) (read-bytes-evt credit i))
-		       bytes-length))
-      ((lines) (values (lambda (credit) (read-line-evt i (compute-terminator options)))
-		       (lambda (v) 1)))
-      ((bytes-lines) (values (lambda (credit) (read-bytes-line-evt i (compute-terminator options)))
-			     (lambda (v) 1)))
-      (else (error 'tcp-socket-actor "Illegal read-evt mode ~v" read-mode))))
-  (thread (lambda ()
-	    (define handle (join-room room name))
-	    (log-info (format "~v: New connection" name))
-	    (with-handlers
-		((exn? (lambda (e)
-			 (close-ports)
-			 (raise e))))
-	      (let loop ((options options)
-			 (peer-count 0)
-			 (remaining-credit (option-value options 'initial-read-credit 0)))
-		;;(write `(connection-loop ,options ,peer-count ,remaining-credit)) (newline)
-		(sync (handle-evt (send handle disconnected-evt)
-				  (lambda (reason)
-				    (log-error (format "~v: conversation closed: ~v" name reason))))
-		      (handle-evt (send handle listen-evt)
-				  (match-lambda
-				   ((arrived _)
-				    (loop options (+ peer-count 1) remaining-credit))
-				   ((departed _ _)
-				    (if (= peer-count 1)
-					(log-info (format "~v: Last peer departed" name))
-					(loop options (- peer-count 1) remaining-credit)))
-				   ((says _ (credit _ amount) _)
-				    (loop options peer-count (+ remaining-credit amount)))
-				   ((says _ (? eof-object?) _)
-				    (close-output-port o)
-				    (loop options peer-count remaining-credit))
-				   ((says _ (? bytes? bs) _)
-				    ;; TODO: credit flow the other way?
-				    (write-bytes bs o)
-				    (flush-output o)
-				    (loop options peer-count remaining-credit))
-				   ((says _ (? string? s) _)
-				    ;; TODO: credit flow the other way?
-				    (write-string s o)
-				    (flush-output o)
-				    (loop options peer-count remaining-credit))
-				   ((says _ (set-options new-values) _)
-				    (loop new-values peer-count remaining-credit))
-				   (unexpected
-				    (log-warning (format "~v: Ignoring message: ~v"
-							 name unexpected))
-				    (loop options peer-count remaining-credit))))
-		      (if (positive? remaining-credit)
-			  (let-values (((e-maker credit-adjuster) (compute-read-evt options)))
-			    (handle-evt (e-maker remaining-credit)
-					(lambda (v)
-					  (if (eof-object? v)
-					      (begin (send handle say v 'eof)
-						     (loop options peer-count 0))
-					      (begin (send handle say v 'data)
-						     (loop options peer-count
-							   (- remaining-credit
-							      (credit-adjuster v))))))))
-			  never-evt)))
-	      (close-ports))))
-  room)

conversation.rkt

@@ -1,248 +0,0 @@
-#lang racket/base
-
-(require racket/bool)
-(require racket/match)
-(require racket/class)
-(require racket/list)
-
-(require "functional-queue.rkt")
-(require "blocking-box.rkt")
-(require "standard-thread.rkt")
-
-(provide make-room
-	 room?
-	 room-name
-	 join-room
-	 wait-for-members
-	 spy-on
-
-	 ;; Management and communication
-	 (struct-out arrived)
-	 (struct-out departed)
-	 (struct-out says)
-
-	 ;; Generic utility messages
-	 (struct-out credit)
-
-	 (struct-out rpc-request)
-	 (struct-out rpc-reply) ;; error is a kind of reply; crashes are detected via disconnection
-	 )
-
-(struct arrived (who) #:prefab) ;; someone arrived
-(struct departed (who why) #:prefab) ;; someone departed with a reason
-(struct says (who what topic) #:prefab) ;; someone said something with a given topic
-
-(struct credit (who amount) #:prefab) ;; give someone an amount of credit
-
-(struct rpc-request (reply-to id body) #:prefab)
-(struct rpc-reply (id body) #:prefab)
-
-(struct room (name ch))
-
-(struct room-state (name ch members) #:transparent)
-(struct binding (name ;; any
-		 invisible? ;; boolean
-		 in-ch ;; sync channel
-		 out-ch ;; sync channel
-		 disconnect-box ;; blocking-box
-		 queue-box ;; box of functional queue
-		 thread ;; thread
-		 exit-status) ;; maybe exit-status
-	#:transparent)
-
-(define (make-room [name (gensym 'room)])
-  (define ch (make-channel))
-  (thread (lambda () (room-main (room-state name ch '()))))
-  (room name ch))
-
-(define (join-room room [name (gensym 'peer)]
-		   #:invisible? [invisible? #f])
-  (make-object membership% (room-ch room) name invisible?))
-
-(define (wait-for-members room members)
-  (define handle (join-room room (gensym 'wait-for-members) #:invisible? #t))
-  (let loop ((remaining-members members))
-    (if (null? remaining-members)
-	#t
-	(match (send handle listen)
-	  ((arrived who) (loop (remove who remaining-members)))
-	  ((departed who _) (if (member who members)
-				(error 'wait-for-members "Waited-for member exited")
-				(loop remaining-members)))
-	  (_ (loop remaining-members)))))
-  (send handle depart))
-
-(define (spy-on room)
-  (thread (lambda ()
-	    (define spy-name (gensym 'spy))
-	    (define handle (join-room room spy-name #:invisible? #t))
-	    (let loop ()
-	      (define message (send handle listen))
-	      (log-info (format "~s/~s: ~s" spy-name (room-name room) message))
-	      (loop)))))
-
-(define membership%
-  (class* object% ()
-    (init room-init)
-    (init name-init)
-    (init invisible?-init)
-
-    (super-new)
-
-    (define room room-init)
-    (define name name-init)
-    (define in-ch (make-channel))
-    (define out-ch (make-channel))
-    (define disconnect-box (make-blocking-box))
-    (define connected #t)
-    (define reason #f)
-
-    (define the-disconnected-evt (wrap-evt (blocking-box-evt disconnect-box)
-					   (lambda (v)
-					     (set! connected #f)
-					     (set! reason v)
-					     v)))
-    (channel-put room `(join ,name ,invisible?-init
-			     ,out-ch ,in-ch ,disconnect-box
-			     ,(current-thread) ,(current-thread-exit-status)))
-
-    (define/public (reply-name)
-      name)
-
-    (define/public (connected?)
-      connected)
-
-    (define/public (disconnect-reason)
-      reason)
-
-    (define/public (disconnected-evt)
-      the-disconnected-evt)
-
-    (define/public (say-evt what [topic #f])
-      (choice-evt the-disconnected-evt
-		  (channel-put-evt out-ch (says name what topic))))
-
-    (define/public (say what [topic #f])
-      (sync (say-evt what topic)))
-
-    (define/public (depart-evt [why #f])
-      (choice-evt the-disconnected-evt
-		  (wrap-evt (channel-put-evt out-ch (departed name why))
-			    (lambda (v)
-			      (set! connected #f)
-			      (set! reason why)))))
-
-    (define/public (depart [why #f])
-      (sync (depart-evt why)))
-
-    (define/public (listen-evt)
-      ;; we wrap this event because otherwise we leak authority
-      (wrap-evt in-ch values))
-
-    (define/public (try-listen)
-      (channel-try-get in-ch))
-
-    (define/public (listen)
-      (sync (wrap-evt the-disconnected-evt
-		      (lambda (reason)
-			(error 'listen "~v: Disconnected with reason ~v while listening"
-			       name reason)))
-	    (listen-evt)))))
-
-(define (room-main state)
-  ;;(write `(room-main ,state)) (newline)
-  (define handler
-    (sync (foldl (lambda (b acc)
-		   (choice-evt (let ((qb (binding-queue-box b)))
-				 (if (queue-empty? (unbox qb))
-				     acc
-				     (choice-evt acc
-						 (let-values (((first rest) (dequeue (unbox qb))))
-						   (handle-evt (channel-put-evt (binding-out-ch b)
-										first)
-							       (lambda (dummy)
-								 (lambda (state)
-								   (set-box! qb rest)
-								   state)))))))
-			       (handle-evt (binding-in-ch b)
-					   (thread-message-handler b))
-			       (handle-evt (thread-dead-evt (binding-thread b))
-					   (thread-death-handler b))))
-		 (handle-evt (room-state-ch state) join-message-handler)
-		 (room-state-members state))))
-  (room-main (handler state)))
-
-(define (thread-message-handler b)
-  (lambda (message)
-    (lambda (state)
-      (handle-binding-message state b message))))
-
-(define (thread-death-handler b)
-  (lambda (dummy)
-    (lambda (state)
-      (part state b (binding-death-reason b)))))
-
-(define join-message-handler
-  (lambda (message)
-    (lambda (state)
-      (match message
-	(`(join ,name ,invisible? ,in-ch ,out-ch ,disconnect-box
-		,thread ,exit-status)
-	 (join state name invisible? in-ch out-ch disconnect-box
-	       thread exit-status))
-	(unexpected (log-warning (format "room-main: unexpected message ~v" unexpected))
-		    state)))))
-
-(define (binding-death-reason b)
-  (define es (binding-exit-status b))
-  (and es
-       (exit-status-exception es)))
-
-(define (handle-binding-message state b message)
-  (match message
-    ((departed _ why) (part state b why))
-    ((says _ what topic) (broadcast state b (says (binding-name b) what topic)))
-    (else (log-warning (format "handle-binding-message: unexpected message ~v"
-			       message))
-	  state)))
-
-(define (join state name invisible?
-	      in-ch out-ch disconnect-box
-	      thread exit-status)
-  (define b (binding name invisible?
-		     in-ch out-ch disconnect-box
-		     (box (list->queue (membership-summary state)))
-		     thread exit-status))
-  (if invisible?
-      (add-binding state b)
-      (broadcast (add-binding state b) b (arrived name))))
-
-(define (part state b why)
-  (set-blocking-box! (binding-disconnect-box b) why)
-  (if (binding-invisible? b)
-      (remove-binding state b)
-      (broadcast (remove-binding state b) b (departed (binding-name b) why))))
-
-(define (membership-summary state)
-  (filter-map (lambda (member) (and (not (binding-invisible? member))
-				    (arrived (binding-name member))))
-	      (room-state-members state)))
-
-(define (add-binding state b)
-  (struct-copy room-state state
-	       [members (cons b (room-state-members state))]))
-
-(define (remove-binding state b)
-  (struct-copy room-state state
-	       [members (remove b (room-state-members state) eq?)]))
-
-(define (broadcast state b message)
-  (for-each (lambda (member)
-	      (when (not (eq? member b))
-		(enqueue-message! member message)))
-	    (room-state-members state))
-  state)
-
-(define (enqueue-message! b message)
-  (define qb (binding-queue-box b))
-  (set-box! qb (enqueue (unbox qb) message)))

new-server.rkt

@@ -0,0 +1,262 @@
+#lang racket/base
+;; (Temporary) example client and server
+
+(require racket/set)
+(require racket/match)
+(require racket/contract)
+(require (only-in racket/port peek-bytes-avail!-evt))
+(require "cook-port.rkt")
+(require "sandboxes.rkt")
+
+(require "ssh-numbers.rkt")
+(require "ssh-transport.rkt")
+(require "ssh-session.rkt")
+(require "ssh-channel.rkt")
+(require "ssh-message-types.rkt")
+(require "ssh-exceptions.rkt")
+(require "os2-support.rkt")
+
+(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 #:debug-name 'ssh-tcp-listener))))
+
+(define listener
+  (transition 'no-state
+    (role (tcp-listener 2322)
+      #:topic t
+      #:on-presence (spawn (session-vm t) #:debug-name (debug-name 'ssh-session-vm t)))))
+
+;;---------------------------------------------------------------------------
+
+(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
+  ;; we've reached some notion of the right place and also input to
+  ;; the hash function used during D-H key exchange.
+  (when (not (regexp-match required-peer-identification-regex
+			   peer-identification-string))
+    (error 'ssh-session
+	   "Invalid peer identification string ~v"
+	   peer-identification-string)))
+
+(define (spy marker)
+  (role (or (topic-subscriber (wild) #:monitor? #t)
+	    (topic-publisher (wild) #:monitor? #t))
+    [message
+     (write `(,marker ,message))
+     (newline)
+     (flush-output)
+     (void)]))
+
+(define-syntax-rule (wait-for topic-of-interest action ...)
+  (role/fresh role-name topic-of-interest
+    #:state state
+    #:on-presence (sequence-actions (transition state)
+		    (delete-role role-name)
+		    action ...)))
+
+(define (session-vm new-connection-topic)
+  (define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
+  (define local-identification #"SSH-2.0-RacketSSH_0.0")
+
+  (define (issue-identification-string)
+    (at-meta-level (cout (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 in-topic
+	 #:name 'socket-reader
+	 #:state state
+	 [(tcp-channel _ _ (? eof-object?))
+	  (transition state (quit))]
+	 [(tcp-channel _ _ (? bytes? remote-identification))
+	  (check-remote-identification! remote-identification)
+	  (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.
+	    (lambda (ignored-state) (ssh-reader new-connection-topic))
+	    ;; Finally, spawn the remaining processes and issue the initial credit to the reader.
+	    (spawn (ssh-writer new-connection-topic)
+		   #:exit-signal? #t
+		   #:debug-name 'ssh-writer)
+	    ;; Wait for the reader and writer get started, then tell
+	    ;; 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)
+	      (wait-for (topic-publisher (outbound-packet (wild)) #:monitor? #t)
+		(send-message (inbound-credit 1))
+		(spawn (ssh-session local-identification
+				    remote-identification
+				    repl-boot
+				    'server)
+		       #:exit-signal? #t
+		       #: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 exit-signals %%%
+    (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 (quit #:reason (and interesting? reason)))))))
+
+  (define (inert-exception-handler reason)
+    inert-exception-handler)
+
+  (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)
+
+      ;; 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 (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)
+  (transition 'no-repl-state
+    (spawn event-relay #:debug-name (debug-name 'repl-event-relay))
+    (spy 'APP)
+    (at-meta-level
+     (role (topic-subscriber (channel-message (channel-stream-name #t (wild)) (wild)))
+       #:state state
+       #:topic t
+       #:on-presence (match t
+		       [(topic _ (channel-message (channel-stream-name _ cname) _) _)
+			(transition state (spawn (repl-instance user-name cname)
+						 #:debug-name cname))])))))
+
+
+;; (repl-instance InputPort OutputPort InputPort OutputPort)
+(struct repl-instance-state (c2s-in ;; used by thread to read input from relay
+			     c2s-out ;; used by relay to feed input from remote to the thread
+			     s2c-in ;; used by relay to feed output from thread to remote
+			     s2c-out ;; used by thread to write output to relay
+			     ) #:prefab)
+
+(define (repl-instance user-name cname)
+  (define inbound-stream (channel-stream-name #t cname))
+  (define outbound-stream (channel-stream-name #f cname))
+  (define (ch-do action-ctor stream body)
+    (at-meta-level (action-ctor (channel-message stream body))))
+  (define (handle-channel-message state body)
+    (match body
+      [(channel-stream-request #"pty-req" _)
+       (match-define (repl-instance-state old-in _ _ old-out) state)
+       (define-values (cooked-in cooked-out) (cook-io old-in old-out "> "))
+       (transition (struct-copy repl-instance-state state
+				[c2s-in cooked-in]
+				[s2c-out cooked-out])
+	 (ch-do send-feedback inbound-stream (channel-stream-ok)))]
+      [(channel-stream-notify #"env" _)
+       ;; Don't care
+       (transition state)]
+      [(channel-stream-request #"shell" _)
+       (match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state)
+       (define buffer-size 1024)
+       (define dummy-buffer (make-bytes buffer-size))
+       (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 (topic-subscriber (cons (thread-dead-evt repl-thread) (wild)))
+	   [_ (quit #: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
+	   ;; of the buffer. The overwriting can happen when there's
+	   ;; any latency between handling the event and the next
+	   ;; firing of the event, since the peek-bytes-avail!-evt
+	   ;; will overwrite its buffer next time it's synced on.
+	   #:state state
+	   [(cons _ (? eof-object?))
+	    (match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
+	    (close-input-port c2s-in)
+	    (close-output-port c2s-out)
+	    (close-input-port s2c-in)
+	    (close-output-port s2c-out)
+	    (transition state (quit))]
+	   [(cons _ (? number? count))
+	    (transition state
+	      (ch-do send-message outbound-stream (channel-stream-data
+						   (read-bytes count s2c-in))))]))]
+      [(or (channel-stream-data #"\4") ;; C-d a.k.a EOT
+	   (channel-stream-eof))
+       (close-output-port (repl-instance-state-c2s-out state))
+       ;; ^ this signals the repl thread to exit.
+       ;; Now, wait for it to do so.
+       (transition state)]
+      [(channel-stream-data bs)
+       (write-bytes bs (repl-instance-state-c2s-out state))
+       (flush-output (repl-instance-state-c2s-out state))
+       (transition state
+	 (ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))]
+      [m
+       (write `(channel inbound ,m)) (newline)
+       (transition state)]))
+  (match (channel-name-type cname)
+    [#"session"
+     (define-values (c2s-in c2s-out) (make-pipe))
+     (define-values (s2c-in s2c-out) (make-pipe))
+     (transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
+       (at-meta-level
+	(role (topic-subscriber (channel-message inbound-stream (wild)))
+	  #:state state
+	  #:on-presence (transition state
+			  (ch-do send-feedback inbound-stream (channel-stream-config
+							       (default-packet-limit)
+							       #""))
+			  (ch-do send-feedback inbound-stream (channel-stream-credit 1024)))
+	  [(channel-message _ body)
+	   (handle-channel-message state body)]))
+       (at-meta-level
+	(role (topic-publisher (channel-message outbound-stream (wild)))
+	  [m
+	   (write `(channel outbound ,cname ,m)) (newline)
+	   (void)])))]
+    [type
+     (transition 'no-instance-state
+       (at-meta-level (send-message
+		       (channel-message outbound-stream
+					(channel-stream-open-failure
+					 SSH_OPEN_UNKNOWN_CHANNEL_TYPE
+					 (bytes-append #"Unknown channel type " type))))))]))
+
+;;---------------------------------------------------------------------------
+
+;; TODO: module+
+(main)

os2-support.rkt

@@ -0,0 +1,12 @@
+#lang racket/base
+;; Reexport racket-matrix module contents.
+
+(require "../racket-matrix/os2.rkt")
+(require "../racket-matrix/os2-event-relay.rkt")
+(require "../racket-matrix/os2-timer.rkt")
+(require "../racket-matrix/fake-tcp.rkt")
+
+(provide (all-from-out "../racket-matrix/os2.rkt"))
+(provide (all-from-out "../racket-matrix/os2-event-relay.rkt"))
+(provide (all-from-out "../racket-matrix/os2-timer.rkt"))
+(provide (all-from-out "../racket-matrix/fake-tcp.rkt"))

sandboxes.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+;; Sandbox management and use.
+
+(require racket/match)
+(require racket/sandbox)
+
+(provide repl-shell)
+
+(struct user-state (name master-sandbox master-namespace) #:transparent)
+
+(define *user-states* (make-hash))
+
+(define (get-user-state username)
+  (when (not (hash-has-key? *user-states* username))
+    (let* ((sb (make-evaluator 'racket/base))
+	   (ns (call-in-sandbox-context sb current-namespace)))
+      (hash-set! *user-states* username
+		 (user-state username
+			     sb
+			     ns))))
+  (hash-ref *user-states* username))
+
+(define (repl-shell username in out)
+  (match-define (user-state _ master-sandbox master-namespace) (get-user-state username))
+  (parameterize ((current-input-port in)
+		 (current-output-port out)
+		 (current-error-port out)
+		 (sandbox-input in)
+		 (sandbox-output out)
+		 (sandbox-error-output out)
+		 (sandbox-memory-limit 2) ;; megabytes
+		 (sandbox-eval-limits #f)
+		 (sandbox-namespace-specs (list (lambda () master-namespace))))
+    (printf "Hello, ~a.\n" username)
+    (define slave-sandbox (make-evaluator '(begin)))
+    ;; ^^ uses master-namespace via sandbox-namespace-specs
+    (parameterize ((current-namespace master-namespace)
+		   (current-eval slave-sandbox))
+      (read-eval-print-loop))
+    (fprintf out "\nGoodbye!\n")
+    (kill-evaluator slave-sandbox)
+    (close-input-port in)
+    (close-output-port out)))

ssh-channel.rkt

@@ -0,0 +1,121 @@
+#lang racket/base
+
+(require racket/set)
+(require racket/match)
+
+(require "ssh-numbers.rkt")
+(require "ssh-message-types.rkt")
+(require "ssh-exceptions.rkt")
+
+(require "os2-support.rkt")
+
+(provide (struct-out ssh-channel)
+
+	 (struct-out channel-name)
+	 (struct-out channel-stream-name)
+	 (struct-out channel-message)
+
+	 (struct-out channel-stream-credit)
+	 (struct-out channel-stream-data)
+	 (struct-out channel-stream-extended-data)
+	 (struct-out channel-stream-eof)
+	 (struct-out channel-stream-notify)
+	 (struct-out channel-stream-request)
+	 (struct-out channel-stream-ok)
+	 (struct-out channel-stream-fail)
+	 (struct-out channel-stream-config)
+	 (struct-out channel-stream-open-failure))
+
+;; A CloseState is one of
+;; - 'neither, indicating that neither side has signalled closure
+;; - 'local, only the local end has signalled closure
+;; - 'remote, only the remote end has signalled closure
+;; - 'both, both ends have signalled closure.
+;; Represents local knowledge of the state of a shared shutdown state
+;; machine.
+;;
+;;                'neither
+;;                /       \
+;;              \/         \/
+;;           'local      'remote
+;;               \         /
+;;                \/     \/
+;;                  'both
+
+;; TODO: Once the presence-based routing table can be queried, the
+;; CloseState becomes redundant, because we can just ask which roles
+;; remain to decide whether either direction is still open.
+
+;; A ChannelState is a (ssh-channel ...) TODO
+;; Named ssh-channel to avoid conflicts with Racket's built-in
+;; synchronous channels.
+(struct ssh-channel (name ;; ChannelName
+		     local-ref ;; Uint32
+		     remote-ref ;; Maybe<Uint32>
+		     outbound-packet-size ;; Maybe<Natural>
+		     close-state ;; CloseState covering CLOSE signals
+		     )
+	#:transparent)
+
+;; ChannelName = (channel-name Boolean Bytes Any)
+;; Names a channel within a connection. Unique within a particular
+;; connection. If (locally-originated?) is true, then the local peer
+;; is the one that opened this channel, and the local peer is
+;; reponsible for choosing the (identifier) and ensuring that it is
+;; unique with respect to other locally-originated streams within this
+;; connection; if false, the remote peer opened the channel, and the
+;; (identifier) is chosen managed by the connection-control code. If
+;; (locally-originated?) is true, the (type) is chosen by the local
+;; peer, otherwise it is chosen by the remote peer.
+(struct channel-name (locally-originated? type identifier) #:prefab)
+
+;; ChannelStreamName = (channel-stream-name Boolean ChannelName)
+;; Names a stream within a channel within a connection. If (inbound?)
+;; is true, this is the stream of packets from the remote peer to the
+;; local peer; if false, the reverse.
+(struct channel-stream-name (inbound? channel) #:prefab)
+
+;; ChannelMessage = (channel-message ChannelStreamName ChannelMessageBody)
+;; Relates a message to a particular stream within a channel within a
+;; connection.
+(struct channel-message (stream-name body) #:prefab)
+
+;; A ChannelMessageBody is one of
+;; -- (channel-stream-credit NonNegativeInteger) **
+;;    Informs the publisher that it may transmit another (count)
+;;    bytes.
+;; -- (channel-stream-data Bytes)
+;;    Data intended for the subscriber.
+;; -- (channel-stream-extended-data Uint32 Bytes)
+;;    Extended data intended for the subscriber. The type code is one
+;;    of those defined in ssh-numbers.rkt; for example,
+;;    SSH_EXTENDED_DATA_STDERR.
+;; -- (channel-stream-eof)
+;;    Signals the end of the data stream. Notice that channel closure
+;;    is signalled with presence changes.
+;; -- (channel-stream-notify Bytes Bytes)
+;;    One-way notification of SSH_MSG_CHANNEL_REQUEST.
+;; -- (channel-stream-request Bytes Bytes)
+;;    RPC SSH_MSG_CHANNEL_REQUEST request.
+;; -- (channel-stream-ok) **
+;;    RPC SSH_MSG_CHANNEL_REQUEST reply.
+;; -- (channel-stream-fail) **
+;;    RPC SSH_MSG_CHANNEL_REQUEST error.
+;; -- (channel-stream-config Uint32 Bytes) **
+;;    Either SSH_MSG_CHANNEL_OPEN or
+;;    SSH_MSG_CHANNEL_OPEN_CONFIRMATION, depending on direction of
+;;    travel. Must be sent before any channel-stream-credit messages.
+;; -- (channel-stream-open-failure Uint32 Bytes)
+;;    SSH_MSG_CHANNEL_OPEN_FAILURE.
+;;
+;; Messages marked ** travel "upstream", from subscriber to publisher.
+(struct channel-stream-credit (count) #:prefab)
+(struct channel-stream-data (bytes) #:prefab)
+(struct channel-stream-extended-data (type bytes) #:prefab)
+(struct channel-stream-eof () #:prefab)
+(struct channel-stream-notify (type bytes) #:prefab)
+(struct channel-stream-request (type bytes) #:prefab)
+(struct channel-stream-ok () #:prefab)
+(struct channel-stream-fail () #:prefab)
+(struct channel-stream-config (maximum-packet-size extra-data) #:prefab)
+(struct channel-stream-open-failure (reason description) #:prefab)

ssh-message-types.rkt

@@ -20,8 +20,7 @@
 	 mpint-width
 	 t:name-list)
 
-(provide (struct-out ssh-msg)
-	 (struct-out ssh-msg-kexinit)
+(provide (struct-out ssh-msg-kexinit)
 	 (struct-out ssh-msg-kexdh-init)
 	 (struct-out ssh-msg-kexdh-reply)
 	 (struct-out ssh-msg-disconnect)
@@ -50,13 +49,9 @@
 	 (struct-out ssh-msg-channel-failure)
 	 )
 
-(struct ssh-msg () #:transparent)
-
+(define encoder-map (make-hasheqv))
 (define decoder-map (make-hasheqv))
 
-(define-values (prop:ssh-message-encoder ssh-message-encoder? ssh-message-encoder)
-  (make-struct-type-property 'ssh-message-encoder))
-
 (define (ssh-message-decode packet)
   (define type-code (bytes-ref packet 0))
   (define decoder (hash-ref decoder-map type-code #f))
@@ -65,74 +60,90 @@
       #f))
 
 (define (ssh-message-encode m)
-  (bit-string->bytes ((ssh-message-encoder m) m)))
+  (bit-string->bytes ((hash-ref encoder-map (prefab-struct-key m)) m)))
 
 (define-syntax define-ssh-message-type
   (syntax-rules ()
     ((_ name type-byte-value (field-type field-name) ...)
      (begin
-       (struct name ssh-msg (field-name ...)
-	       #:transparent
-	       #:property prop:ssh-message-encoder
-	       (compute-ssh-message-encoder type-byte-value field-type ...))
+       (struct name (field-name ...) #:prefab)
+       (hash-set! encoder-map 'name
+		  (compute-ssh-message-encoder type-byte-value field-type ...))
        (hash-set! decoder-map type-byte-value
 		  (compute-ssh-message-decoder name type-byte-value field-type ...))))))
 
 (define-syntax t:boolean
   (syntax-rules ()
-    ((_ #t) (lambda (input ks kf)
-	      (bit-string-case input
-		([ v (rest :: binary) ]
-		 (ks (not (zero? v)) rest))
-		(else (kf)))))
-    ((_ #f) (lambda (v) (bit-string (if v 1 0))))))
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ v (rest :: binary) ]
+	(ks (not (zero? v)) rest))
+       (else (kf))))
+    ((_ #f v) (bit-string (if v 1 0)))))
+
+(define-syntax t:packed-bytes
+  (syntax-rules ()
+    ((_ #t input ks kf n)
+     (bit-string-case input
+       ([ (bs :: binary bytes n) (rest :: binary) ]
+	(ks (bit-string->bytes bs) rest))
+       (else (kf))))
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ (rest :: binary) ]
+	(ks (bit-string->bytes rest) #""))
+       (else (kf))))
+    ((_ #f bs n) (bit-string (bs :: binary)))
+    ((_ #f bs) (bit-string (bs :: binary)))))
 
 (define-syntax t:string
   (syntax-rules ()
-    ((_ #t #:pack) (lambda (input ks kf)
-		     ((t:string #t) input (lambda (v rest) (ks (bit-string->bytes v) rest)) kf)))
-    ((_ #t) (lambda (input ks kf)
-	      (bit-string-case input
-		([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
-		 (ks body rest))
-		(else (kf)))))
-    ((_ #f) (lambda (bs)
-	      (bit-string ((bytes-length (bit-string->bytes bs)) :: integer bits 32)
-			  (bs :: binary))))))
+    ((_ #t input ks kf #:pack)
+     (t:string #t input (lambda (v rest) (ks (bit-string->bytes v) rest)) kf))
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
+	(ks body rest))
+       (else (kf))))
+    ((_ #f bs #:pack) (t:string #f bs)) ;; #:pack ignored on encoding
+    ((_ #f bs)
+     (bit-string ((bytes-length (bit-string->bytes bs)) :: integer bits 32)
+		 (bs :: binary)))))
 
 (define-syntax t:mpint
   (syntax-rules ()
-    ((_ #t) (lambda (input ks kf)
-	      (bit-string-case input
-		([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
-		 (ks (if (zero? (bit-string-length body)) 0 (bit-string->integer body #t #t))
-		     rest))
-		(else (kf)))))
-    ((_ #f) (lambda (n)
-	      (let* ((width (mpint-width n))
-		     (buf (integer->bit-string n (* 8 width) #t)))
-		(bit-string (width :: integer bits 32) (buf :: binary)))))))
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
+	(ks (if (zero? (bit-string-length body)) 0 (bit-string->integer body #t #t))
+	    rest))
+       (else (kf))))
+    ((_ #f n)
+     (let* ((width (mpint-width n))
+	    (buf (integer->bit-string n (* 8 width) #t)))
+       (bit-string (width :: integer bits 32) (buf :: binary))))))
 
 (define-syntax t:name-list
   (syntax-rules ()
-    ((_ #t) (lambda (input ks kf)
-	      ((t:string #t) input
-	                     (lambda (body rest) (ks (name-list->symbols body) rest))
-			     kf)))
-    ((_ #f) (lambda (ns)
-	      ((t:string #f) (symbols->name-list ns))))))
+    ((_ #t input ks kf)
+     (t:string #t
+	       input
+	       (lambda (body rest) (ks (name-list->symbols body) rest))
+	       kf))
+    ((_ #f ns)
+     (t:string #f (symbols->name-list ns)))))
 
 (define-for-syntax (codec-options field-type)
   (syntax-case field-type (byte boolean uint32 uint64 string mpint name-list)
     (byte #'(integer bits 8))
-    ((byte n) #'(binary bytes n))
+    ((byte n) #'((t:packed-bytes n)))
     (boolean #'((t:boolean)))
     (uint32 #'(integer bits 32))
     (uint64 #'(integer bits 64))
-    (string #'((t:string)))
+    (string #'((t:string #:pack)))
     (mpint #'((t:mpint)))
     (name-list #'((t:name-list)))
-    (extension #'(binary))))
+    (extension #'((t:packed-bytes)))))
 
 (define-syntax compute-ssh-message-encoder
   (lambda (stx)
@@ -185,13 +196,12 @@
       '()
       (map string->symbol (regexp-split #rx"," (bytes->string/utf-8 (bit-string->bytes bs))))))
 
-(struct test-message (value)
-	#:transparent
-	#:property prop:ssh-message-encoder (compute-ssh-message-encoder 123 mpint))
-(let ((test-decode (compute-ssh-message-decoder test-message 123 mpint)))
+(struct test-message (value) #:prefab)
+(let ((test-decode (compute-ssh-message-decoder test-message 123 mpint))
+      (test-encode (compute-ssh-message-encoder 123 mpint)))
   (define (bidi-check msg enc-without-type-tag)
     (let ((enc (bytes-append (bytes 123) enc-without-type-tag)))
-      (let ((msg-enc (ssh-message-encode msg))
+      (let ((msg-enc (bit-string->bytes (test-encode msg)))
 	    (enc-msg (test-decode enc)))
 	(if (and (equal? msg-enc enc)
 		 (equal? enc-msg msg))

ssh-transport.rkt

@@ -2,20 +2,24 @@
 
 (require (planet tonyg/bitsyntax))
 (require (planet vyzo/crypto:2:3))
-(require racket/port)
-(require racket/class)
+
+(require racket/set)
 (require racket/match)
 
 (require rackunit)
 
 (require "aes-ctr.rkt")
-(require "conversation.rkt")
 
 (require "ssh-numbers.rkt")
 (require "ssh-message-types.rkt")
 (require "ssh-exceptions.rkt")
 
-(provide (struct-out received-packet)
+(require "os2-support.rkt")
+
+(provide (struct-out inbound-packet)
+	 (struct-out inbound-credit)
+	 (struct-out outbound-packet)
+	 (struct-out outbound-byte-credit)
 	 (struct-out new-keys)
 
 	 default-packet-limit
@@ -31,17 +35,24 @@
 ;; A DecodedPacket is one of the packet structures defined in
 ;; ssh-message-types.rkt.
 
-;; A ReceivedPacket is a (received-packet Number Bytes Maybe<DecodedPacket> Number)
-;; representing a packet read from the socket, its sequence number,
-;; and the total number of bytes involved in its reception.
-(struct received-packet (sequence-number payload message transfer-size) #:transparent)
+;; An InboundPacket is an (inbound-packet Number Bytes
+;; Maybe<DecodedPacket> Number) representing a packet read from the
+;; socket, its sequence number, and the total number of bytes involved
+;; in its reception.
+(struct inbound-packet (sequence-number payload message transfer-size) #:prefab)
+
+(struct inbound-credit (amount) #:prefab)
+
+(struct outbound-packet (message) #:prefab)
+
+(struct outbound-byte-credit (amount) #:prefab)
 
 (struct new-keys (is-server?
 		  derive-key
 		  c2s-enc s2c-enc
 		  c2s-mac s2c-mac
 		  c2s-zip s2c-zip)
-	#:transparent)
+	#:prefab)
 
 (struct crypto-configuration (cipher
 			      cipher-description
@@ -266,104 +277,135 @@
 ;; Encrypted Packet Input
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (ssh-reader in room)
-  (define handle (join-room room 'read-thread))
+(struct ssh-reader-state (mode config sequence-number remaining-credit) #:prefab)
+
+(define (ssh-reader new-connection-topic)
+  (define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
   (define packet-size-limit (default-packet-limit))
 
-  (define (main-loop config sequence-number remaining-credit)
-    (match-define (crypto-configuration cipher cipher-description
-					hmac hmac-description) config)
-    (define block-size (supported-cipher-block-size cipher-description))
-    (define first-block-size block-size)
-    (define subsequent-block-size (if cipher block-size 1))
-    (define decryptor (if cipher cipher values))
+  (define (issue-credit state)
+    (match-define (ssh-reader-state _ (crypto-configuration _ desc _ _) _ message-credit) state)
+    (when (positive? message-credit)
+      (at-meta-level (cin (tcp-credit (supported-cipher-block-size desc))))))
 
-    (define (handle-packet-start first-block)
-      (define packet-length (integer-bytes->integer first-block #f #t 0 4))
-      (check-packet-length! packet-length packet-size-limit subsequent-block-size)
-      (define padding-length (bytes-ref first-block 4))
-      (define payload-length (- packet-length padding-length 1))
-      (define amount-of-packet-in-first-block
-	(- (bytes-length first-block) 4)) ;; not incl length
-      (define remaining-to-read (- packet-length amount-of-packet-in-first-block))
+  (transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0)
+    (at-meta-level
+     (role in-topic
+       #:name 'socket-reader
+       #:state (and state
+		    (ssh-reader-state mode
+				      (crypto-configuration cipher
+							    cipher-description
+							    hmac
+							    hmac-description)
+				      sequence-number
+				      remaining-credit))
+       [(tcp-channel _ _ (? eof-object?))
+	(transition state (quit))]
+       [(tcp-channel _ _ (? bytes? encrypted-packet))
+	(define block-size (supported-cipher-block-size cipher-description))
+	(define first-block-size block-size)
+	(define subsequent-block-size (if cipher block-size 1))
+	(define decryptor (if cipher cipher values))
 
-      (define (check-hmac! computed-hmac-bytes)
-	(define mac-byte-count (bytes-length computed-hmac-bytes))
-	(when (positive? mac-byte-count)
-	  (match (read-bytes mac-byte-count in)
-	    ((? eof-object?) (disconnect-with-error SSH_DISCONNECT_CONNECTION_LOST
-						    "EOF instead of MAC"))
-	    (received-hmac-bytes
-	     (when (not (equal? computed-hmac-bytes received-hmac-bytes))
+	(define (check-hmac packet-length payload-length packet)
+	  (define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
+	  (define mac-byte-count (bytes-length computed-hmac-bytes))
+	  (if (positive? mac-byte-count)
+	      (transition (struct-copy ssh-reader-state state
+				       [mode `(packet-hmac ,computed-hmac-bytes
+							   ,mac-byte-count
+							   ,packet-length
+							   ,payload-length
+							   ,packet)])
+		(at-meta-level (cin (tcp-credit mac-byte-count))))
+	      (finish-packet 0 packet-length payload-length packet)))
+
+	(define (finish-packet mac-byte-count packet-length payload-length packet)
+	  (define bytes-read (+ packet-length mac-byte-count))
+	  (define payload (subbytes packet 5 (+ 5 payload-length)))
+	  (define new-credit (- remaining-credit 1))
+	  (define new-state (struct-copy ssh-reader-state state
+					 [mode 'packet-header]
+					 [sequence-number (+ sequence-number 1)]
+					 [remaining-credit new-credit]))
+	  (transition new-state
+	    (issue-credit new-state)
+	    (send-message
+	     (inbound-packet sequence-number payload (ssh-message-decode payload) bytes-read))))
+
+	(match mode
+	  ['packet-header
+	   (define decrypted-packet (decryptor encrypted-packet))
+	   (define first-block decrypted-packet)
+	   (define packet-length (integer-bytes->integer first-block #f #t 0 4))
+	   (check-packet-length! packet-length packet-size-limit subsequent-block-size)
+	   (define padding-length (bytes-ref first-block 4))
+	   (define payload-length (- packet-length padding-length 1))
+	   (define amount-of-packet-in-first-block
+	     (- (bytes-length first-block) 4)) ;; not incl length
+	   (define remaining-to-read (- packet-length amount-of-packet-in-first-block))
+
+	   (if (positive? remaining-to-read)
+	       (transition (struct-copy ssh-reader-state state
+					[mode `(packet-body ,packet-length
+							    ,payload-length
+							    ,first-block)])
+		 (at-meta-level (cin (tcp-credit remaining-to-read))))
+	       (check-hmac packet-length payload-length first-block))]
+
+	  [`(packet-body ,packet-length ,payload-length ,first-block)
+	   (define decrypted-packet (decryptor encrypted-packet))
+	   (check-hmac packet-length payload-length (bytes-append first-block decrypted-packet))]
+
+	  [`(packet-hmac ,computed-hmac-bytes
+			 ,mac-byte-count
+			 ,packet-length
+			 ,payload-length
+			 ,main-packet)
+	   (define received-hmac-bytes encrypted-packet) ;; not really encrypted!
+	   (if (equal? computed-hmac-bytes received-hmac-bytes)
+	       (finish-packet mac-byte-count packet-length payload-length main-packet)
 	       (disconnect-with-error/local-info `((expected-hmac ,computed-hmac-bytes)
 						   (actual-hmac ,received-hmac-bytes))
 						 SSH_DISCONNECT_MAC_ERROR
-						 "Corrupt MAC")))))
-	mac-byte-count)
-
-      (define (finish-packet packet)
-	(define bytes-read
-	  (+ packet-length (check-hmac! (apply-hmac hmac sequence-number packet))))
-	(define payload (subbytes packet 5 (+ 5 payload-length)))
-	(send handle say
-	      (received-packet sequence-number payload (ssh-message-decode payload) bytes-read)
-	      'packet)
-	(main-loop config (+ sequence-number 1) (- remaining-credit 1)))
-
-      (if (positive? remaining-to-read)
-	  (match (read-bytes remaining-to-read in)
-	    ((? eof-object?) (disconnect-with-error SSH_DISCONNECT_CONNECTION_LOST
-						    "EOF mid-way through reading a packet"))
-	    (encrypted (finish-packet (bytes-append first-block (decryptor encrypted)))))
-	  (finish-packet first-block)))
-
-    (let wait-for-event ()
-      (sync (if (positive? remaining-credit)
-		(handle-evt (read-bytes-evt first-block-size in)
-			    (lambda (encrypted)
-			      (cond
-			       ((eof-object? encrypted)
-				(send handle depart 'eof)) ;; we gracefully exit
-			       (else (handle-packet-start (decryptor encrypted))))))
-		never-evt)
-	    (handle-evt (send handle listen-evt)
-			(match-lambda
-			 ((arrived _) (wait-for-event))
-			 ((and departure (departed _ _)) (send handle depart departure))
-			 ((says _ (credit 'read-thread amount) _)
-			  (main-loop config sequence-number (+ remaining-credit amount)))
-			 ((says _ (? new-keys? nk) _)
-			  (main-loop (apply-negotiated-options nk #f)
-				     sequence-number remaining-credit))
-			 ((says _ _ _) (wait-for-event)))))))
-
-  (with-handlers ((exn? (lambda (e)
-			  (close-input-port in)
-			  (raise e))))
-    (main-loop initial-crypto-configuration 0 0)
-    (close-input-port in)))
+						 "Corrupt MAC"))])]))
+    (role (topic-subscriber (inbound-credit (wild)))
+      #:state state
+      [(inbound-credit amount)
+       (define new-state (struct-copy ssh-reader-state state
+				      [remaining-credit
+				       (+ amount (ssh-reader-state-remaining-credit state))]))
+       (transition new-state
+	 (issue-credit new-state))])
+    (role (topic-subscriber (new-keys (wild)
+				      (wild)
+				      (wild) (wild)
+				      (wild) (wild)
+				      (wild) (wild)))
+      #:state state
+      [(? new-keys? nk)
+       (transition (struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)]))])
+    (role (topic-publisher (inbound-packet (wild) (wild) (wild) (wild))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Encrypted Packet Output
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (ssh-writer out room)
-  (define handle (join-room room 'write-thread))
+(struct ssh-writer-state (config sequence-number) #:prefab)
 
-  (define (main-loop config sequence-number)
-    (match-define (crypto-configuration cipher cipher-description
-					hmac hmac-description) config)
-
-    (match (send handle listen)
-      ((arrived _)
-       (main-loop config sequence-number))
-      ((and departure (departed _ _)) (send handle depart departure))
-      ((says _ (? new-keys? nk) _)
-       (main-loop (apply-negotiated-options nk #t) sequence-number))
-      ((says _ 'flush _)
-       (flush-output out)
-       (main-loop config sequence-number))
-      ((says _ (? ssh-msg? message) _)
+(define (ssh-writer new-connection-topic)
+  (define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
+  (transition (ssh-writer-state initial-crypto-configuration 0)
+    (role (set (topic-subscriber (outbound-packet (wild)))
+	       (topic-publisher (outbound-byte-credit (wild))))
+      #:state (and state
+		   (ssh-writer-state (crypto-configuration cipher
+							   cipher-description
+							   hmac
+							   hmac-description)
+				     sequence-number))
+      [(outbound-packet message)
        (define pad-block-size (supported-cipher-block-size cipher-description))
        (define encryptor (if cipher cipher values))
        (define payload (ssh-message-encode message))
@@ -383,17 +425,18 @@
 				   ((random-bytes padding-length) :: binary))))
        (define encrypted-packet (encryptor packet))
        (define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
-       (write-bytes encrypted-packet out)
        (define mac-byte-count (bytes-length computed-hmac-bytes))
-       (when (positive? mac-byte-count)
-	 (write-bytes computed-hmac-bytes out))
-       (send handle say (+ (bytes-length encrypted-packet) mac-byte-count) 'output-byte-count)
-       (main-loop config (+ sequence-number 1)))
-      ((says _ _ _)
-       (main-loop config sequence-number))))
-
-  (with-handlers ((exn? (lambda (e)
-			  (close-output-port out)
-			  (raise e))))
-    (main-loop initial-crypto-configuration 0)
-    (close-output-port out)))
+       (transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)])
+	 (at-meta-level (cout encrypted-packet))
+	 (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 (topic-subscriber (new-keys (wild)
+				      (wild)
+				      (wild) (wild)
+				      (wild) (wild)
+				      (wild) (wild)))
+      #:state state
+      [(? new-keys? nk)
+       (transition
+	   (struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))

test-conversation-socket.rkt

@@ -1,73 +0,0 @@
-#lang racket/base
-
-(require racket/class)
-(require racket/match)
-
-(require "conversation.rkt")
-(require "conversation-socket.rkt")
-
-(define pool (make-room 'everybody))
-
-(define (handle-connection sock quit-proc)
-  (join-room pool)
-  (define h (join-room sock))
-  (match (send h listen)
-    ((arrived peer-name)
-     (let loop ()
-       (send h say "Ready>> ")
-       (sync (handle-evt (send h listen-evt)
-			 (match-lambda
-			  ((says _ _ 'eof)
-			   (send h say "OK, bye\n"))
-			  ((says _ "quit" 'data)
-			   (send h say (credit peer-name 1))
-			   (quit-proc)
-			   (send h say "OK, will quit accepting\n")
-			   (loop))
-			  ((says _ what 'data)
-			   (write what)
-			   (newline)
-			   (send h say (credit #f 1))
-			   (send h say "Carry on\n")
-			   (loop))
-			  ((departed _ _) (void))
-			  (else (loop))))
-	     (handle-evt (send h disconnected-evt) void))))))
-
-(define (listen port-no)
-  (define r (make-room))
-  (tcp-server-actor r
-		    `((initial-accept-credit 1)
-		      (read-mode lines)
-		      (initial-read-credit 1))
-		    port-no)
-  (define h (join-room r 'main))
-  (match (send h listen)
-    ((arrived listener-name)
-     (let loop ()
-       (match (send h listen)
-	 ((says _ sock 'accepted)
-	  (thread (lambda ()
-		    (handle-connection sock
-				       (lambda ()
-					 (send h depart 'told-to-quit)))))
-	  (send h say (credit listener-name 1)))
-	 (unexpected
-	  (write `(unexpected ,unexpected))
-	  (newline)))
-       (loop)))))
-
-(thread (lambda ()
-	  (join-room pool)
-	  (listen 5001)))
-
-(define (wait-until-pool-empty)
-  (define h (join-room pool))
-  (let loop ((count 0))
-    (match (send h listen)
-      ((arrived _) (loop (+ count 1)))
-      ((departed _ _) (if (= count 1)
-			  'done
-			  (loop (- count 1))))
-      (_ (loop count)))))
-(wait-until-pool-empty)

test-conversation.rkt

@@ -1,61 +0,0 @@
-#lang racket/base
-
-(require racket/tcp)
-(require racket/port)
-(require racket/class)
-(require racket/match)
-
-(require "conversation.rkt")
-(require "standard-thread.rkt")
-
-(define r (make-room))
-
-(thread (lambda ()
-	  (define handle (join-room r 'robot))
-	  (let loop ()
-	    (match (send handle listen)
-	      ((says _ "die" _)
-	       (error 'robot "Following orders!"))
-	      ((and m (says _ _ _))
-	       (send handle say `(robot hears ,m) 'echo))
-	      (else (void)))
-	    (loop))))
-
-(define (interaction i o)
-  (display "What is your name? > " o)
-  (flush-output o)
-  (define name (read-line i))
-  (if (eof-object? name)
-      (begin (display "OK, bye then!" o)
-	     (flush-output o))
-      (let ((handle (join-room r name)))
-	(let loop ()
-	  (display name o)
-	  (display "@ROOM>> " o)
-	  (flush-output o)
-	  (sync (handle-evt (send handle listen-evt)
-			    (lambda (m)
-			      (write `(,name hears ,m) o)
-			      (newline o)
-			      (flush-output o)
-			      (loop)))
-		(handle-evt (read-line-evt i 'any)
-			    (lambda (utterance)
-			      (when (equal? utterance "error")
-				(error 'interaction "Following orders!"))
-			      (when (not (eof-object? utterance))
-				(send handle say utterance 'speech)
-				(loop)))))))))
-
-(thread (lambda ()
-	  (interaction (current-input-port) (current-output-port))))
-
-(let ((s (tcp-listen 5001 4 #t)))
-  (let accept-loop ()
-    (define-values (i o) (tcp-accept s))
-    (thread (lambda ()
-	      (interaction i o)
-	      (close-input-port i)
-	      (close-output-port o)))
-    (accept-loop)))
-