Switch to fixcopyright package

Switch from (planet vyzo/crypto) to crypto.
Comment out most of the upper layers of the protocol.
Switch to new syndicate/rkt.

Unfortunately since I last ran this, the set of MUST-implement kex
methods has changed and there's no overlap with my default SSH client :-)

COPYING

@@ -1,7 +1,7 @@
                     GNU GENERAL PUBLIC LICENSE
                        Version 3, 29 June 2007
 
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
  Everyone is permitted to copy and distribute verbatim copies
  of this license document, but changing it is not allowed.
 
@@ -645,7 +645,7 @@ the "copyright" line and a pointer to where the full notice is found.
     GNU General Public License for more details.
 
     You should have received a copy of the GNU General Public License
-    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+    along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 Also add information on how to contact you by electronic and paper mail.
 
@@ -664,11 +664,11 @@ might be different; for a GUI interface, you would use an "about box".
   You should also get your employer (if you work as a programmer) or school,
 if any, to sign a "copyright disclaimer" for the program, if necessary.
 For more information on this, and how to apply and follow the GNU GPL, see
-<http://www.gnu.org/licenses/>.
+<https://www.gnu.org/licenses/>.
 
   The GNU General Public License does not permit incorporating your program
 into proprietary programs.  If your program is a subroutine library, you
 may consider it more useful to permit linking proprietary applications with
 the library.  If this is what you want to do, use the GNU Lesser General
 Public License instead of this License.  But first, please read
-<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+<https://www.gnu.org/licenses/why-not-lgpl.html>.

COPYING.LESSER

@@ -0,0 +1,165 @@
+                   GNU LESSER GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+  This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+  0. Additional Definitions.
+
+  As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+  "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+  An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+  A "Combined Work" is a work produced by combining or linking an
+Application with the Library.  The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+  The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+  The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+  1. Exception to Section 3 of the GNU GPL.
+
+  You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+  2. Conveying Modified Versions.
+
+  If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+   a) under this License, provided that you make a good faith effort to
+   ensure that, in the event an Application does not supply the
+   function or data, the facility still operates, and performs
+   whatever part of its purpose remains meaningful, or
+
+   b) under the GNU GPL, with none of the additional permissions of
+   this License applicable to that copy.
+
+  3. Object Code Incorporating Material from Library Header Files.
+
+  The object code form of an Application may incorporate material from
+a header file that is part of the Library.  You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+   a) Give prominent notice with each copy of the object code that the
+   Library is used in it and that the Library and its use are
+   covered by this License.
+
+   b) Accompany the object code with a copy of the GNU GPL and this license
+   document.
+
+  4. Combined Works.
+
+  You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+   a) Give prominent notice with each copy of the Combined Work that
+   the Library is used in it and that the Library and its use are
+   covered by this License.
+
+   b) Accompany the Combined Work with a copy of the GNU GPL and this license
+   document.
+
+   c) For a Combined Work that displays copyright notices during
+   execution, include the copyright notice for the Library among
+   these notices, as well as a reference directing the user to the
+   copies of the GNU GPL and this license document.
+
+   d) Do one of the following:
+
+       0) Convey the Minimal Corresponding Source under the terms of this
+       License, and the Corresponding Application Code in a form
+       suitable for, and under terms that permit, the user to
+       recombine or relink the Application with a modified version of
+       the Linked Version to produce a modified Combined Work, in the
+       manner specified by section 6 of the GNU GPL for conveying
+       Corresponding Source.
+
+       1) Use a suitable shared library mechanism for linking with the
+       Library.  A suitable mechanism is one that (a) uses at run time
+       a copy of the Library already present on the user's computer
+       system, and (b) will operate properly with a modified version
+       of the Library that is interface-compatible with the Linked
+       Version.
+
+   e) Provide Installation Information, but only if you would otherwise
+   be required to provide such information under section 6 of the
+   GNU GPL, and only to the extent that such information is
+   necessary to install and execute a modified version of the
+   Combined Work produced by recombining or relinking the
+   Application with a modified version of the Linked Version. (If
+   you use option 4d0, the Installation Information must accompany
+   the Minimal Corresponding Source and Corresponding Application
+   Code. If you use option 4d1, you must provide the Installation
+   Information in the manner specified by section 6 of the GNU GPL
+   for conveying Corresponding Source.)
+
+  5. Combined Libraries.
+
+  You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+   a) Accompany the combined library with a copy of the same work based
+   on the Library, uncombined with any other library facilities,
+   conveyed under the terms of this License.
+
+   b) Give prominent notice with the combined library that part of it
+   is a work based on the Library, and explaining where to find the
+   accompanying uncombined form of the same work.
+
+  6. Revised Versions of the GNU Lesser General Public License.
+
+  The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+  Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+  If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.

Makefile

@@ -1,5 +1,27 @@
-all:
-	raco make new-server.rkt
+__ignored__ := $(shell ./setup.sh)
+
+PACKAGES=syndicate-ssh
+COLLECTS=syndicate-ssh
+
+all: setup
 
 clean:
 	find . -name compiled -type d | xargs rm -rf
+	find . -name '*.rkte' | xargs rm -rf
+
+setup:
+	raco setup --check-pkg-deps --unused-pkg-deps $(COLLECTS)
+
+link:
+	raco pkg install --link $(PACKAGES)
+
+unlink:
+	raco pkg remove $(PACKAGES)
+
+test: setup testonly
+
+testonly:
+	raco test -p $(PACKAGES)
+
+fixcopyright:
+	-fixcopyright.rkt --preset-racket LGPL-3.0-or-later

README.md

@@ -2,60 +2,16 @@
 
 This is a [Racket](http://racket-lang.org/) implementation of the SSH
 v2 protocol. It's written to work with
-[Marketplace](https://github.com/tonyg/marketplace), but could readily
-be adapted to work with other I/O substrates. (It originally used
-Racket's `sync` and events directly.)
+[Syndicate](https://syndicate-lang.org/), but could readily be adapted
+to work with other I/O substrates. (It originally used Racket's `sync`
+and events directly.)
 
-The code is not quite fully separated into a reusable library yet: at
-present, it is a hard-coded Racket REPL server. Changing this is
-straightforward, but low-priority right now. Patches welcome!
+## Copyright and Licence
 
-## How to compile and run the code
+Copyright 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
 
-You will need the latest **prerelease** version of Racket. Any version
-newer than or equal to Racket 5.3.4.10 should work. Nightly-build
-installers for Racket can be downloaded
-[here](http://pre.racket-lang.org/installers/).
+This program is distributed under the terms of the [LGPLv3
+license](https://opensource.org/licenses/lgpl-3.0.html) or any later version.
 
-Once you have Racket installed,
-
-    raco pkg install marketplace bitsyntax
-
-to install Marketplace (note: will take a long time) and
-[bitsyntax](https://github.com/tonyg/racket-bitsyntax/), and then
-
-    make
-
-(or the equivalent, `raco make new-server.rkt`) to compile the SSH
-code. Once it has compiled successfully,
-
-    racket new-server.rkt
-
-will start the server running on `localhost` port 2322. Log in to the
-server with
-
-    ssh localhost -p 2322
-
-To enable debug output, try
-
-    MATRIX_LOG=info racket new-server.rkt
-
-## Copyright and License
-
-Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-
-This file is part of marketplace-ssh.
-
-marketplace-ssh is free software: you can redistribute it and/or
-modify it under the terms of the GNU General Public License as
-published by the Free Software Foundation, either version 3 of the
-License, or (at your option) any later version.
-
-marketplace-ssh is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with marketplace-ssh. If not, see
-<http://www.gnu.org/licenses/>.
+Documentation is distributed under the terms of the [CC BY 4.0
+license](https://creativecommons.org/licenses/by/4.0/).

aes-ctr.rkt

@@ -1,81 +0,0 @@
-#lang racket/base
-;; Provide AES CTR mode, since OpenSSL's EVP support for AES CTR mode
-;; is still ifdef'd out.
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(provide start-aes-ctr
-	 aes-ctr-process!)
-
-(require ffi/unsafe)
-(require ffi/unsafe/define)
-(require openssl/libcrypto)
-
-(define _AES_KEY-pointer _pointer)
-
-(define AES_BLOCK_SIZE 16)
-(define sizeof-AES_KEY 244) ;; TODO: figure out a good way to get this
-			    ;; from the header file or the library
-			    ;; itself
-
-(define-ffi-definer define-crypto libcrypto
-  #:default-make-fail make-not-available)
-
-(define-crypto AES_set_encrypt_key (_fun _pointer _int _AES_KEY-pointer -> _int))
-;;(define-crypto AES_set_decrypt_key (_fun _pointer _int _AES_KEY-pointer -> _int))
-
-(define-crypto AES_ctr128_encrypt
-  (_fun _pointer ;; in
-	_pointer ;; out
-	_long ;; length
-	_AES_KEY-pointer ;; key
-	_pointer ;; ivec, AES_BLOCK_SIZE bytes
-	_pointer ;; ecount_buf, AES_BLOCK_SIZE bytes
-	_pointer ;; int pointer, the "num" field of the ongoing state (??)
-	-> _void))
-
-(struct aes-ctr-state (key ivec ecount num) #:transparent)
-
-(define (start-aes-ctr key initialization-vector)
-  (let ((key-buffer (malloc sizeof-AES_KEY))
-	(ivec (make-bytes AES_BLOCK_SIZE))
-	(ecount (make-bytes AES_BLOCK_SIZE))
-	(num (make-bytes (ctype-sizeof _int))))
-    (AES_set_encrypt_key key
-			 (* 8 (bytes-length key)) ;; measured in bits
-			 key-buffer)
-    (bytes-copy! ivec 0 initialization-vector 0 AES_BLOCK_SIZE)
-    (bytes-fill! ecount 0)
-    (bytes-fill! num 0)
-    (aes-ctr-state key-buffer
-		   ivec
-		   ecount
-		   num)))
-
-(define (aes-ctr-process! state input-block)
-  (define block-length (bytes-length input-block))
-  (define output-block (make-bytes block-length))
-  (AES_ctr128_encrypt input-block
-		      output-block
-		      block-length
-		      (aes-ctr-state-key state)
-		      (aes-ctr-state-ivec state)
-		      (aes-ctr-state-ecount state)
-		      (aes-ctr-state-num state))
-  output-block)

asn1-ber.rkt

@@ -1,182 +0,0 @@
-#lang racket/base
-;; A very small subset of ASN.1 BER (from ITU-T X.690), suitable for
-;; en- and decoding public-key data for the ssh-rsa and ssh-dss
-;; algorithms.
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(require racket/match)
-(require bitsyntax)
-
-(provide t:long-ber-tag
-	 t:ber-length-indicator
-
-	 asn1-ber-decode-all
-	 asn1-ber-decode
-	 asn1-ber-encode)
-
-(define-syntax t:long-ber-tag
-  (syntax-rules ()
-    ((_ #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)
-	     (input input))
-    (bit-string-case input
-      ([ (= 1 :: bits 1)
-	 (x :: bits 7)
-	 (rest :: binary) ]
-       (loop (+ x (arithmetic-shift acc 7)) rest))
-      ([ (= 0 :: bits 1)
-	 (x :: bits 7)
-	 (rest :: binary) ]
-       (when (not (zero? x)))
-       (ks (+ x (arithmetic-shift acc 7)) rest))
-      (else (kf)))))
-
-(define (write-long-tag v)
-  (list->bytes
-   (reverse-and-set-high-bits
-    (let loop ((v v))
-      (if (< v 128)
-	  (list v)
-	  (cons (bitwise-and v 127)
-		(loop (arithmetic-shift v -7))))))))
-
-(define (reverse-and-set-high-bits bs)
-  (let loop ((acc (list (car bs)))
-	     (bs (cdr bs)))
-    (if (null? bs)
-	acc
-	(loop (cons (bitwise-ior 128 (car bs)) acc) (cdr bs)))))
-
-(define-syntax t:ber-length-indicator
-  (syntax-rules ()
-    ((_ #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)))
-    (if (equal? rest #"")
-	value
-	(error 'asn1-ber-decode-all "Trailing bytes present in encoded ASN.1 BER term"))))
-
-(define (asn1-ber-decode packet)
-  (asn1-ber-decode* packet (lambda (class tag value rest)
-			     (values (list class tag value)
-				     (bit-string->bytes rest)))))
-
-(define (asn1-ber-decode* packet k)
-  (bit-string-case packet
-    ;; Tag with number >= 31
-    ([ (class :: bits 2)
-       (constructed :: bits 1)
-       (= 31 :: bits 5)
-       (tag :: (t:long-ber-tag))
-       (length :: (t:ber-length-indicator))
-       (rest :: binary) ]
-     (asn1-ber-decode-contents class constructed tag length rest k))
-    ([ (class :: bits 2)
-       (constructed :: bits 1)
-       (tag :: bits 5)
-       (length :: (t:ber-length-indicator))
-       (rest :: binary) ]
-     (asn1-ber-decode-contents class constructed tag length rest k))))
-
-(define (asn1-ber-decode-contents class constructed tag length rest k)
-  (cond
-   ((= constructed 1)
-    (define indefinite? (eq? length 'indefinite))
-    (define block (if indefinite? rest (sub-bit-string rest 0 (* length 8))))
-    (asn1-ber-decode-seq block indefinite? (lambda (seq rest) (k class tag seq rest))))
-   ((= constructed 0)
-    (bit-string-case rest
-      ([ (block :: binary bytes length)
-	 (rest :: binary) ]
-       (k class tag (bit-string->bytes block) rest))))))
-
-(define (asn1-ber-decode-seq packet indefinite? k)
-  (let loop ((rest packet)
-	     (k k))
-    (if (and (bit-string-empty? rest)
-	     (not indefinite?))
-	(k '() rest)
-	(asn1-ber-decode* rest
-			  (lambda (class tag value rest)
-			    (if (and indefinite?
-				     (= class 0)
-				     (= tag 0)
-				     (equal? value #""))
-				(k '() rest)
-				(loop rest
-				      (lambda (seq rest)
-					(k (cons (list class tag value) seq) rest)))))))))
-
-(define (asn1-ber-encode entry)
-  (bit-string->bytes (asn1-ber-encode* entry)))
-
-(define (asn1-ber-encode* entry)
-  (match entry
-    (`(,class ,tag ,value)
-     (if (list? value)
-	 (let* ((encoded-values (map asn1-ber-encode* value))
-		(content-octets (foldr bit-string-append #"" encoded-values))
-		(content-length (quotient (bit-string-length content-octets) 8)))
-	   (bit-string (class :: bits 2)
-		       (1 :: bits 1) ;; constructed
-		       ((asn1-ber-encode-tag tag) :: binary)
-		       (content-length :: (t:ber-length-indicator))
-		       (content-octets :: binary bytes content-length)))
-	 (bit-string (class :: bits 2)
-		     (0 :: bits 1) ;; not constructed
-		     ((asn1-ber-encode-tag tag) :: binary)
-		     ((bytes-length value) :: (t:ber-length-indicator))
-		     (value :: binary))))))
-
-(define (asn1-ber-encode-tag tag)
-  (if (>= tag 31)
-      (bit-string (31 :: bits 5) (tag :: (t:long-ber-tag)))
-      (bit-string (tag :: bits 5))))

drive.sh

@@ -4,13 +4,13 @@ serverpid=$!
 echo "Serverpid is $serverpid"
 while true
 do
-    if netstat -an | grep -q '2322.*LISTEN'
+    if netstat -an | grep -q '29418.*LISTEN'
     then
 	break
     fi
     sleep 0.1
 done
-echo '(+ 1 2 3 4 5 6)' | ssh localhost -p 2322
+echo '(+ 1 2 3 4 5 6)' | ssh localhost -p 29418
 sleep 1
 kill -INT $serverpid
 echo "Killed $serverpid"

functional-queue.rkt

@@ -1,93 +0,0 @@
-#lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(provide make-queue
-	 queue?
-	 enqueue
-	 enqueue-all
-	 dequeue
-	 list->queue
-	 queue->list
-	 queue-length
-	 queue-empty?
-	 queue-append
-	 queue-extract)
-
-(struct queue (head tail) #:transparent)
-
-(define (make-queue)
-  (queue '() '()))
-
-(define (enqueue q v)
-  (queue (queue-head q)
-	 (cons v (queue-tail q))))
-
-(define (enqueue-all q v)
-  (queue (queue-head q)
-	 (append (reverse v) (queue-tail q))))
-
-(define (shuffle q)
-  (if (null? (queue-head q))
-      (queue (reverse (queue-tail q)) '())
-      q))
-
-(define (dequeue q)
-  (let ((q1 (shuffle q)))
-    (values (car (queue-head q1))
-	    (queue (cdr (queue-head q1)) (queue-tail q1)))))
-
-(define (list->queue xs)
-  (queue xs '()))
-
-(define (queue->list q)
-  (append (queue-head q) (reverse (queue-tail q))))
-
-(define (queue-length q)
-  (+ (length (queue-head q))
-     (length (queue-tail q))))
-
-(define (queue-empty? q)
-  (and (null? (queue-head q))
-       (null? (queue-tail q))))
-
-(define (queue-append q1 q2)
-  (queue (append (queue-head q1)
-		 (reverse (queue-tail q1))
-		 (queue-head q2))
-	 (queue-tail q2)))
-
-(define (queue-extract q predicate [default-value #f])
-  (let search-head ((head (queue-head q))
-		    (rejected-head-rev '()))
-    (cond
-     ((null? head) (let search-tail ((tail (reverse (queue-tail q)))
-				     (rejected-tail-rev '()))
-		     (cond
-		      ((null? tail) (values default-value q))
-		      ((predicate (car tail)) (values (car tail)
-						      (queue (queue-head q)
-							     (append (reverse (cdr tail))
-								     rejected-tail-rev))))
-		      (else (search-tail (cdr tail) (cons (car tail) rejected-tail-rev))))))
-     ((predicate (car head)) (values (car head)
-				     (queue (append (reverse rejected-head-rev)
-						    (cdr head))
-					    (queue-tail q))))
-     (else (search-head (cdr head) (cons (car head) rejected-head-rev))))))

git-hooks/pre-commit

@@ -0,0 +1,4 @@
+#!/bin/sh
+set -e
+exec 1>&2
+fixcopyright.rkt -n --preset-racket LGPL-3.0-or-later

marketplace-support.rkt

@@ -1,30 +0,0 @@
-#lang racket/base
-;; Reexport racket-matrix module contents.
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(require marketplace/sugar)
-(require marketplace/drivers/tcp)
-(require marketplace/drivers/timer)
-(require marketplace/drivers/event-relay)
-
-(provide (all-from-out marketplace/sugar))
-(provide (all-from-out marketplace/drivers/tcp))
-(provide (all-from-out marketplace/drivers/timer))
-(provide (all-from-out marketplace/drivers/event-relay))

new-server.rkt

@@ -1,300 +0,0 @@
-#lang racket/base
-;; (Temporary) example client and server
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(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 "marketplace-support.rkt")
-
-(define (main)
-  (ground-vm (timer-driver)
-	     (tcp-driver)
-	     (tcp-spy)
-	     (name-process 'ssh-tcp-listener (spawn listener))))
-
-(define listener
-  (transition/no-state
-    (observe-publishers (tcp-channel ? (tcp-listener 2322) ?)
-      (match-conversation r
-	(on-presence (session-vm r))))))
-
-;;---------------------------------------------------------------------------
-
-(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)
-  (define (dump what message)
-    (write `(,marker ,what ,message))
-    (newline)
-    (flush-output)
-    (void))
-  (list
-   (observe-publishers/everything (wild)
-     (match-interest-type i
-       (match-conversation c
-	 (on-presence (dump 'arrived (role 'publisher c i)))
-	 (on-absence (dump 'departed (role 'publisher c i)))
-	 (on-message [message (dump 'message message)]))))
-   (observe-subscribers/everything (wild)
-     (match-interest-type i
-       (match-conversation c
-	 (on-presence (dump 'arrived (role 'subscriber c i)))
-	 (on-absence (dump 'departed (role 'subscriber c i)))
-	 (on-message [message (dump 'feedback message)]))))))
-
-(define-syntax-rule (wait-as my-orientation topic action ...)
-  (let-fresh (endpoint-name)
-    (build-endpoint endpoint-name
-		    (role my-orientation topic 'observer)
-		    (match-state state
-		      (on-presence (sequence-actions (transition state
-						       (delete-endpoint endpoint-name)
-						       action ...)))))))
-
-(define (session-vm new-conversation)
-  (match-define (tcp-channel remote-addr local-addr _) new-conversation)
-  (define local-identification #"SSH-2.0-RacketSSH_0.0")
-
-  (define (issue-identification-string)
-    (at-meta-level
-     (send-message (tcp-channel local-addr remote-addr
-				(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
-       (name-endpoint 'socket-reader
-	 (subscriber (tcp-channel remote-addr local-addr ?)
-	   (match-state state
-	     (on-message
-	      [(tcp-channel _ _ (? eof-object?))
-	       (transition state (quit))]
-	      [(tcp-channel _ _ (? bytes? remote-identification))
-	       (begin
-		 (check-remote-identification! remote-identification)
-		 (sequence-actions (transition state)
-		   ;; First, set the incoming mode to bytes.
-		   (at-meta-level
-		    (send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes))))
-		   ;; Then initialise the reader, switching to packet-reading mode.
-		   (lambda (ignored-state) (ssh-reader new-conversation))
-		   ;; Finally, spawn the remaining processes and issue
-		   ;; the initial credit to the reader.
-		   (name-process 'ssh-writer
-		     ;; TODO: canary: #:exit-signal? #t
-		     (spawn (ssh-writer new-conversation)))
-		   ;; 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-as 'subscriber (inbound-packet (wild) (wild) (wild) (wild))
-			    (wait-as 'publisher (outbound-packet (wild))
-				     (send-message (inbound-credit 1))
-				     (name-process 'ssh-session
-				       (spawn #:pid session-pid
-					      ;; TODO: canary: #:exit-signal? #t
-					      (ssh-session session-pid
-							   local-identification
-							   remote-identification
-							   repl-boot
-							   'server)))))))])))))))
-
-  (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 ;; gross
-	(transition state (at-meta-level (quit #f (and interesting? reason)))))))
-
-  (define (inert-exception-handler reason)
-    inert-exception-handler)
-
-  (spawn-vm #:debug-name (list 'ssh-session-vm new-conversation)
-    (event-relay 'ssh-event-relay)
-    (timer-relay '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
-     (send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'lines)))
-     (send-feedback (tcp-channel remote-addr local-addr (tcp-credit 1))))
-
-    (name-process 'ssh-reader
-      ;; TODO: canary: #:exit-signal? #t
-      (spawn (read-handshake-and-become-reader)))
-
-    ;; TODO: canary:
-    ;; (spawn #:child
-    ;; 	   (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)
-  (list
-   (event-relay 'app-event-relay)
-   (spy 'APP)
-   (at-meta-level
-    (subscriber (channel-message (channel-stream-name #t (wild)) (wild))
-      (match-conversation (channel-message (channel-stream-name _ cname) _)
-	(on-presence (name-process cname (spawn (repl-instance user-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))
-	 (subscriber (cons (thread-dead-evt repl-thread) (wild))
-	   (on-message [_ (quit #f "REPL thread exited")]))
-	 (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.
-	   (match-state state
-	     (on-message
-	      [(cons _ (? eof-object?))
-	       (let ()
-		 (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))
-       (let ()
-	 (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
-	(subscriber (channel-message inbound-stream (wild))
-	  (match-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))))
-	    (on-message
-	     [(channel-message _ body)
-	      (handle-channel-message state body)]))))
-       (at-meta-level
-	(publisher (channel-message outbound-stream (wild))
-	  (on-message [m (begin
-			   (write `(channel outbound ,cname ,m)) (newline)
-			   (void))]))))]
-    [type
-     (transition/no-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)

oakley-groups.rkt

@@ -1,46 +0,0 @@
-#lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;; Construct Oakley MODP Diffie-Hellman groups from RFCs 2409 and 3526.
-
-(provide dh:oakley-group-2
-	 dh:oakley-group-14)
-
-;;(require (planet vyzo/crypto))
-(require (planet vyzo/crypto/dh))
-(require (only-in net/base64 base64-decode))
-
-(define dh:oakley-group-2
-  (make-!dh
-   1024
-   (base64-decode
-    #"MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE
-      3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta
-      iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC")))
-
-(define dh:oakley-group-14
-  (make-!dh
-   2048
-   (base64-decode
-    #"MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO
-      NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr
-      +1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc
-      YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei
-      j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==")))

protocols/schemas/auth.prs

@@ -0,0 +1,26 @@
+version 1 .
+embeddedType EntityRef.Cap .
+
+SshAuthenticatedUser = <authenticated @username string @service bytes>.
+
+SshAuthMethod =
+  / @none #"none"
+  / @publickey #"publickey"
+  / @password #"password"
+.
+
+SshAuthRequest =
+  / <none @username string>
+  / <publickey @username string @key PublicKey>
+  / <password @username string @password string>
+.
+
+SshAuthenticationMethodAcceptable = <authentication-method-acceptable @method SshAuthMethod>.
+
+SshAuthenticationAcceptable =
+  <authentication-acceptable? @method SshAuthMethod @request SshAuthRequest @ok bool>.
+
+PublicKey = Ed25519PublicKey .
+
+Ed25519PublicKey = <ed25519-public-key @q bytes>.
+Ed25519PrivateKey = <ed25519-private-key @q bytes @d bytes>.

protocols/schemas/channel.prs

@@ -0,0 +1,19 @@
+version 1 .
+embeddedType EntityRef.Cap .
+
+SshChannelTypeAvailable = <channel-type-available @type bytes>.
+
+SshChannelRemote = <channel-remote @type bytes @extraData bytes>.
+SshChannelLocal  = <channel-local  @type bytes @extraData bytes>.
+
+SshChannelOpenResponse =
+  / @ok <channel-open-confirmation @sink #!stream.Sink @extraData bytes>
+  / @fail <channel-open-failure @sink #!stream.Sink @reason int @description bytes>
+.
+
+SshChannelObject =
+  / @extendedData <channel-extended-data @typeCode int>
+  / @request <channel-request @type bytes @wantReply bool>
+  / @success <channel-reply #t>
+  / @failure <channel-reply #f>
+.

sandboxes.rkt

@@ -1,61 +0,0 @@
-#lang racket/base
-;; Sandbox management and use.
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(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)))

setup.sh

@@ -0,0 +1,18 @@
+#!/bin/sh
+#
+# Set up a git checkout of this repository for local dev use.
+
+exec 2>/dev/tty 1>&2
+
+set -e
+
+[ -d .git ] || exit 0
+
+for fullhook in ./git-hooks/*
+do
+    hook=$(basename "$fullhook")
+    [ -L .git/hooks/$hook ] || (
+        echo "Installing $hook hook"
+        ln -s ../../git-hooks/$hook .git/hooks/$hook
+    )
+done

ssh-exceptions.rkt

@@ -1,59 +0,0 @@
-#lang racket/base
-;; Exceptions and error-raising and -handling utilities used in structuring SSH sessions.
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(provide (struct-out exn:fail:contract:protocol)
-	 disconnect-with-error
-	 disconnect-with-error/local-info
-	 disconnect-with-error*)
-
-;; An exn:fail:contract:protocol, when thrown by the transport (TODO:
-;; clarify scope of this behaviour) will cause a SSH_MSG_DISCONNECT to
-;; be sent to the remote party with the included reason code, using
-;; the exn-message as the description. The local-info field is useful
-;; information for diagnosing problems known to the local stack that
-;; should not be transmitted to the remote party. For example, upon
-;; detection of a MAC failure, it might be useful to know the expected
-;; and actual MACs for debugging, but they should not be sent over the
-;; wire because we could be experiencing some kind of attack.
-(struct exn:fail:contract:protocol exn:fail:contract
-	(reason-code local-info originated-at-peer?)
-	#:transparent)
-
-;; Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
-(define (disconnect-with-error reason-code format-string . args)
-  (apply disconnect-with-error* #f '() reason-code format-string args))
-
-;; Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
-(define (disconnect-with-error/local-info local-info reason-code format-string . args)
-  (apply disconnect-with-error* #f local-info reason-code format-string args))
-
-;; Boolean Any Natural FormatString [Any ...] -> raised exn:fail:contract:protocol
-(define (disconnect-with-error* originated-at-peer?
-				local-info
-				reason-code
-				format-string
-				. args)
-  (let ((message (apply format format-string args)))
-    (raise (exn:fail:contract:protocol message
-				       (current-continuation-marks)
-				       reason-code
-				       local-info
-				       originated-at-peer?))))

ssh-host-key.rkt

@@ -1,229 +0,0 @@
-#lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(require racket/match)
-(require racket/port)
-(require net/base64)
-
-(require (planet vyzo/crypto))
-(require bitsyntax)
-(require "asn1-ber.rkt")
-(require "ssh-message-types.rkt")
-
-(require rackunit)
-
-(provide (struct-out rsa-private-key)
-	 (struct-out dsa-private-key)
-	 (struct-out rsa-public-key)
-	 (struct-out dsa-public-key)
-
-	 public-key->pieces
-	 pieces->public-key
-
-	 host-key-algorithm->keys
-	 host-key-algorithm->digest-type
-	 host-key-signature
-	 verify-host-key-signature!
-
-	 pieces->ssh-host-key
-	 ssh-host-key->pieces)
-
-(struct rsa-private-key (version n e d p q dmp1 dmq1 iqmp) #:transparent)
-(struct dsa-private-key (version p q g y x) #:transparent)
-(struct rsa-public-key (n e) #:transparent)
-(struct dsa-public-key (y p q g) #:transparent)
-
-;; ASN.1 BER integers are signed.
-(define (bs->n bs) (bit-string->integer bs #t #t))
-(define (n->bs n) (integer->bit-string n (* 8 (mpint-width n)) #t))
-
-(define (private-key->pieces key)
-  (bytes->private-key-pieces (private-key->bytes key)))
-
-(define (bytes->private-key-pieces bs)
-  (match (asn1-ber-decode-all bs)
-    (`(0 16 ((0 2 ,version-bytes)
-	     (0 2 ,n-bytes)
-	     (0 2 ,e-bytes)
-	     (0 2 ,d-bytes)
-	     (0 2 ,p-bytes)
-	     (0 2 ,q-bytes)
-	     (0 2 ,dmp1-bytes)
-	     (0 2 ,dmq1-bytes)
-	     (0 2 ,iqmp-bytes)))
-     (rsa-private-key (bs->n version-bytes)
-		      (bs->n n-bytes)
-		      (bs->n e-bytes)
-		      (bs->n d-bytes)
-		      (bs->n p-bytes)
-		      (bs->n q-bytes)
-		      (bs->n dmp1-bytes)
-		      (bs->n dmq1-bytes)
-		      (bs->n iqmp-bytes)))
-    (`(0 16 ((0 2 ,version-bytes)
-	     (0 2 ,p-bytes)
-	     (0 2 ,q-bytes)
-	     (0 2 ,g-bytes)
-	     (0 2 ,public-key-bytes) ;; y
-	     (0 2 ,private-key-bytes))) ;; x
-     (dsa-private-key (bs->n version-bytes)
-		      (bs->n p-bytes)
-		      (bs->n q-bytes)
-		      (bs->n g-bytes)
-		      (bs->n public-key-bytes)
-		      (bs->n private-key-bytes)))))
-
-(define (pieces->private-key p)
-  (match p
-    ((struct rsa-private-key (version n e d p q dmp1 dmq1 iqmp))
-     (bytes->private-key pkey:rsa
-			 (asn1-ber-encode `(0 16 ((0 2 ,(n->bs version))
-						  (0 2 ,(n->bs n))
-						  (0 2 ,(n->bs e))
-						  (0 2 ,(n->bs d))
-						  (0 2 ,(n->bs p))
-						  (0 2 ,(n->bs q))
-						  (0 2 ,(n->bs dmp1))
-						  (0 2 ,(n->bs dmq1))
-						  (0 2 ,(n->bs iqmp)))))))
-    ((struct dsa-private-key (version p q g y x))
-     (bytes->private-key pkey:dsa
-			 (asn1-ber-encode `(0 16 ((0 2 ,(n->bs version))
-						  (0 2 ,(n->bs p))
-						  (0 2 ,(n->bs q))
-						  (0 2 ,(n->bs g))
-						  (0 2 ,(n->bs y))
-						  (0 2 ,(n->bs x)))))))))
-
-(define (public-key->pieces key)
-  (match (asn1-ber-decode-all (public-key->bytes key))
-    (`(0 16 ((0 2 ,n-bytes)
-	     (0 2 ,e-bytes)))
-     (rsa-public-key (bs->n n-bytes)
-		     (bs->n e-bytes)))
-    (`(0 16 ((0 2 ,public-key-bytes) ;; y
-	     (0 2 ,p-bytes)
-	     (0 2 ,q-bytes)
-	     (0 2 ,g-bytes)))
-     (dsa-public-key (bs->n public-key-bytes)
-		     (bs->n p-bytes)
-		     (bs->n q-bytes)
-		     (bs->n g-bytes)))))
-
-(define (pieces->public-key p)
-  (match p
-    ((struct rsa-public-key (n e))
-     (bytes->public-key pkey:rsa
-			(asn1-ber-encode `(0 16 ((0 2 ,(n->bs n))
-						 (0 2 ,(n->bs e)))))))
-    ((struct dsa-public-key (y p q g))
-     (bytes->public-key pkey:dsa
-			(asn1-ber-encode `(0 16 ((0 2 ,(n->bs y))
-						 (0 2 ,(n->bs p))
-						 (0 2 ,(n->bs q))
-						 (0 2 ,(n->bs g)))))))))
-
-(define (host-key-algorithm->keys host-key-alg)
-  (case host-key-alg
-    ((ssh-dss) (values host-key-dsa-private host-key-dsa-public))
-    (else (error 'host-key-algorithm->keys "Unsupported host-key-alg ~v" host-key-alg))))
-
-(define (host-key-algorithm->digest-type host-key-alg)
-  (case host-key-alg
-    ((ssh-rsa) digest:sha1)
-    ((ssh-dss) digest:dss1)
-    (else (error 'host-key-algorithm->digest-type "Unsupported host-key-alg ~v" host-key-alg))))
-
-(define (host-key-signature private-key host-key-alg exchange-hash)
-  (case host-key-alg
-    ((ssh-rsa)
-     ;; TODO: offer ssh-rsa. See comment in definition of
-     ;; local-algorithm-list in ssh-transport.rkt.
-     (error 'host-key-signature "ssh-rsa host key signatures unimplemented"))
-    ((ssh-dss)
-     (match (asn1-ber-decode-all (sign private-key digest:dss1 exchange-hash))
-       (`(0 16 ((0 2 ,r-bytes)
-		(0 2 ,s-bytes)))
-	(bit-string (#"ssh-dss" :: (t:string))
-		    ((bit-string ((bs->n r-bytes) :: big-endian integer bits 160)
-				 ((bs->n s-bytes) :: big-endian integer bits 160))
-		     :: (t:string))))))))
-
-(define (verify-host-key-signature! public-key host-key-alg exchange-hash h-signature)
-  ;; TODO: If we are *re*keying, worth checking here that the key hasn't *changed* either.
-  (write `(TODO check-host-key!)) (newline) (flush-output) ;; actually check the identity TOFU/POP
-  (case host-key-alg
-    ((ssh-rsa)
-     ;; TODO: offer ssh-rsa. See comment in definition of
-     ;; local-algorithm-list in ssh-transport.rkt.
-     (error 'verify-host-key-signature! "ssh-rsa host key signatures unimplemented"))
-    ((ssh-dss)
-     (define signature (bit-string-case h-signature
-			 ([ (= #"ssh-dss" :: (t:string #:pack))
-			    (r-and-s :: (t:string)) ]
-			  (bit-string-case r-and-s
-			    ([ (r :: big-endian integer bits 160)
-			       (s :: big-endian integer bits 160) ]
-			     (asn1-ber-encode `(0 16 ((0 2 ,(n->bs r))
-						      (0 2 ,(n->bs s))))))))))
-     (when (not (verify public-key digest:dss1 signature exchange-hash))
-       (error 'verify-host-key-signature! "Signature mismatch")))))
-
-(define (pieces->ssh-host-key pieces)
-  (match pieces
-    ((struct rsa-public-key (n e))
-     (bit-string (#"ssh-rsa" :: (t:string))
-		 (e :: (t:mpint))
-		 (n :: (t:mpint))))
-    ((struct dsa-public-key (y p q g))
-     (bit-string (#"ssh-dss" :: (t:string))
-		 (p :: (t:mpint))
-		 (q :: (t:mpint))
-		 (g :: (t:mpint))
-		 (y :: (t:mpint))))))
-
-(define (ssh-host-key->pieces blob)
-  (bit-string-case blob
-    ([ (= #"ssh-rsa" :: (t:string #:pack))
-       (e :: (t:mpint))
-       (n :: (t:mpint)) ]
-     (rsa-public-key n e))
-    ([ (= #"ssh-dss" :: (t:string #:pack))
-       (p :: (t:mpint))
-       (q :: (t:mpint))
-       (g :: (t:mpint))
-       (y :: (t:mpint)) ]
-     (dsa-public-key y p q g))))
-
-;; TODO: proper store for keys
-
-(define (load-private-key filename)
-  (pieces->private-key
-   (bytes->private-key-pieces
-    (base64-decode
-     (regexp-replace* #rx"(?m:^-.*-$)"
-		      (call-with-input-file filename port->bytes)
-		      #"")))))
-
-(define host-key-dsa-private (load-private-key "test-dsa-key"))
-(define host-key-dsa-public (pkey->public-key host-key-dsa-private))
-
-(check-equal? (public-key->bytes (pieces->public-key (public-key->pieces host-key-dsa-public)))
-	      (public-key->bytes host-key-dsa-private))

ssh-session.rkt

@@ -1,923 +0,0 @@
-#lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(require bitsyntax)
-(require (planet vyzo/crypto:2:3))
-
-(require racket/set)
-(require racket/match)
-
-(require "oakley-groups.rkt")
-
-(require "ssh-host-key.rkt")
-
-(require "ssh-numbers.rkt")
-(require "ssh-message-types.rkt")
-(require "ssh-exceptions.rkt")
-(require "ssh-transport.rkt")
-(require "ssh-channel.rkt")
-
-(require "marketplace-support.rkt")
-
-(provide 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 -> Transition).
-;; The raw received bytes of the packet are given because sometimes
-;; cryptographic operations on the received bytes are mandated by the
-;; protocol.
-
-;; TODO: Remove dispatch-table in favour of using the os2 subscription
-;; mechanism to dispatch packets. I could do this now, but I'd lose
-;; SSH_MSG_UNIMPLEMENTED support: I would need to be able to query the
-;; current routing table to see whether there was an active listener
-;; ready to take a given packet.
-
-;; A ConnectionState is a (connection ... TODO fix this) representing
-;; the complete state of the SSH transport, authentication, and
-;; connection layers.
-(struct connection (discard-next-packet?
-		    dispatch-table
-		    total-transferred
-		    rekey-state
-		    authentication-state
-		    channels ;; ListOf<ChannelState>
-		    is-server?
-		    local-id
-		    remote-id
-		    session-id ;; starts off #f until initial keying
-		    application-boot) ;; used when authentication completes
-	#: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 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)]))
-
-;; Transition 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)
-	    (transition conn
-	      (send-message (outbound-packet (ssh-msg-unimplemented seq))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 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)
-  (transition 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))
-  (transition 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 ((exchange-hash-info-client-id hash-info) :: (t:string))
-		      ((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)
-;;   -> Transition
-;; 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))
-     (transition
-	 (oneshot-handler conn
-			  SSH_MSG_KEXDH_INIT
-			  (lambda (packet message conn)
-			    (define e (ssh-msg-kexdh-init-e message))
-			    (define e-width (mpint-width e))
-			    (define e-as-bytes (integer->bit-string e (* 8 e-width) #t))
-			    (define shared-secret (compute-key private-key e-as-bytes))
-			    (define hash-alg sha1)
-			    (define-values (host-key-private host-key-public)
-			      (host-key-algorithm->keys host-key-alg))
-			    (define host-key-bytes
-			      (pieces->ssh-host-key (public-key->pieces host-key-public)))
-			    (define exchange-hash
-			      (dh-exchange-hash hash-info
-						host-key-bytes
-						e
-						public-key-as-integer
-						(bit-string->integer shared-secret #t #f)))
-			    (define h-signature (host-key-signature host-key-private
-								    host-key-alg
-								    exchange-hash))
-			    (sequence-actions (transition conn)
-			      (send-message (outbound-packet
-					     (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
-								  public-key-as-integer
-								  (bit-string->bytes h-signature))))
-			      (lambda (conn)
-				(finish shared-secret exchange-hash hash-alg conn))))))]
-    [else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
-				 "Bad key-exchange algorithm ~v" kex-alg)]))
-
-;; ExchangeHashInfo Symbol Symbol ConnectionState
-;;   (Bytes Bytes Symbol ConnectionState -> ConnectionState)
-;;   -> Transition
-;; 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))
-     (sequence-actions (transition conn)
-       (send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer)))
-       (lambda (conn)
-	 (transition
-	     (oneshot-handler conn
-			      SSH_MSG_KEXDH_REPLY
-			      (lambda (packet message conn)
-				(define f (ssh-msg-kexdh-reply-f message))
-				(define f-width (mpint-width f))
-				(define f-as-bytes (integer->bit-string f (* 8 f-width) #t))
-				(define shared-secret (compute-key private-key f-as-bytes))
-				(define hash-alg sha1)
-				(define host-key-bytes (ssh-msg-kexdh-reply-host-key message))
-				(define host-public-key
-				  (pieces->public-key (ssh-host-key->pieces host-key-bytes)))
-				(define exchange-hash
-				  (dh-exchange-hash hash-info
-						    host-key-bytes
-						    public-key-as-integer
-						    f
-						    (bit-string->integer shared-secret #t #f)))
-				(verify-host-key-signature! host-public-key
-							    host-key-alg
-							    exchange-hash
-							    (ssh-msg-kexdh-reply-h-signature
-							     message))
-				(finish shared-secret exchange-hash hash-alg conn))))))]
-    [else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
-				 "Bad key-exchange algorithm ~v" kex-alg)]))
-
-;; 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)
-
-  (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))))))))))
-    (transition
-	(oneshot-handler (struct-copy connection conn
-				      [session-id session-id]) ;; just in case it changed
-			 SSH_MSG_NEWKEYS
-			 (lambda (newkeys-packet newkeys-message conn)
-			   ;; First, send our SSH_MSG_NEWKEYS,
-			   ;; incrementing the various counters, and then
-			   ;; apply the new algorithms. Also arm our rekey
-			   ;; timer.
-			   (define new-rekey-state (rekey-in-seconds-or-bytes
-						    (rekey-interval)
-						    (rekey-volume)
-						    (connection-total-transferred conn)))
-			   (transition
-			       (set-handlers
-				(struct-copy connection conn [rekey-state new-rekey-state])
-				SSH_MSG_SERVICE_REQUEST handle-msg-service-request)
-			     (send-message (outbound-packet (ssh-msg-newkeys)))
-			     (send-message
-			      (new-keys (connection-is-server? conn)
-					derive-key
-					c2s-enc s2c-enc
-					c2s-mac s2c-mac
-					c2s-zip s2c-zip))
-			     (send-message (set-timer 'rekey-timer
-						      (* (rekey-wait-deadline new-rekey-state) 1000)
-						      'absolute)))))))
-
-  (sequence-actions (continue-after-discard conn)
-    (when should-discard-first-kex-packet
-      (lambda (conn) (transition (struct-copy connection conn [discard-next-packet? #t]))))
-    (lambda (conn)
-      (if (rekey-wait? (connection-rekey-state conn))
-	  (transition (struct-copy connection conn [rekey-state (rekey-local local-algs)])
-	    (send-message (outbound-packet local-algs)))
-	  (transition conn)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Service request manager
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(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")
-	 (sequence-actions (transition conn)
-	   (send-message (outbound-packet (ssh-msg-service-accept service)))
-	   (lambda (conn) (transition
-			      (oneshot-handler conn
-					       SSH_MSG_USERAUTH_REQUEST
-					       handle-msg-userauth-request)))))]
-    [else
-     (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
-			    "Service ~v not supported"
-			    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
-    (sequence-actions (transition conn)
-      (send-message (outbound-packet (ssh-msg-userauth-success)))
-      (lambda (conn)
-	(start-connection-service
-	 (set-handlers (struct-copy connection conn
-				    [authentication-state (authenticated user-name service-name)])
-		       SSH_MSG_USERAUTH_REQUEST
-		       (lambda (packet message conn)
-			 ;; RFC4252 section 5.1 page 6
-			 conn))))
-      (lambda (conn)
-	(transition conn
-	  ;; TODO: canary for NESTED VM!: #:exit-signal? #t
-	  (spawn-vm #:debug-name 'ssh-application-vm
-		    ((connection-application-boot conn) user-name)))))]
-   [else
-    (transition conn
-      (send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Channel management
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (unused-local-channel-ref conn)
-  (define (bump-candidate candidate)
-    (modulo (+ candidate 1) #x100000000))
-  (define first-candidate (match (connection-channels conn)
-			    ['() 0]
-			    [(cons ch _) (bump-candidate (ssh-channel-local-ref ch))]))
-  (let examine-candidate ((candidate first-candidate))
-    (let loop ((chs (connection-channels conn)))
-      (cond
-       [(null? chs) candidate]
-       [(= (ssh-channel-local-ref (car chs)) candidate)
-	(examine-candidate (bump-candidate candidate))]
-       [else (loop (cdr chs))]))))
-
-(define (replacef proc updater creator lst)
-  (let loop ((lst lst))
-    (cond [(null? lst) (list (creator))]
-	  [(proc (car lst)) (cons (updater (car lst)) (cdr lst))]
-	  [else (cons (car lst) (loop (cdr lst)))])))
-
-(define (remf proc lst)
-  (cond [(null? lst) '()]
-	[(proc (car lst)) (cdr lst)]
-	[else (cons (car lst) (remf proc (cdr lst)))]))
-
-;; ChannelName -> ChannelState -> Boolean
-(define ((ssh-channel-name=? cname) c)
-  (equal? (ssh-channel-name c) cname))
-
-;; Connection Uint32 -> ChannelState
-(define (get-channel conn local-ref)
-  (define ch (findf (lambda (c) (equal? (ssh-channel-local-ref c) local-ref))
-		    (connection-channels conn)))
-  (when (not ch)
-    (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
-			   "Attempt to use known channel local-ref ~v"
-			   local-ref))
-  ch)
-
-;; ChannelName Maybe<Uint32> Connection -> Connection
-(define (update-channel cname updater conn)
-  (struct-copy connection conn
-   [channels
-    (replacef (ssh-channel-name=? cname)
-	      updater
-	      (lambda () (updater (ssh-channel cname
-					       (unused-local-channel-ref conn)
-					       #f
-					       #f
-					       'neither)))
-	      (connection-channels conn))]))
-
-;; ChannelName Connection -> Connection
-(define (discard-channel cname conn)
-  (struct-copy connection conn
-   [channels
-    (remf (ssh-channel-name=? cname) (connection-channels conn))]))
-
-;; 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 cname conn action)
-  (cond
-   [(findf (ssh-channel-name=? cname) (connection-channels conn)) =>
-    (lambda (ch)
-      (define old-close-state (ssh-channel-close-state ch))
-      (define new-close-state (update-close-state old-close-state action))
-      (transition (if (eq? new-close-state 'both)
-		      (discard-channel ch conn)
-		      (update-channel cname
-				      (lambda (ch)
-					(struct-copy ssh-channel ch
-						     [close-state new-close-state]))
-				      conn))
-	(case action
-	  [(local)
-	   (case old-close-state
-	     [(neither remote)
-	      (list (send-message (outbound-packet
-				   (ssh-msg-channel-close (ssh-channel-remote-ref ch)))))]
-	     [else (list)])]
-	  [(remote)
-	   (case old-close-state
-	     [(neither local)
-	      (list (delete-endpoint (list cname 'outbound))
-		    (delete-endpoint (list cname 'inbound)))]
-	     [else (list)])])))]
-   [else (transition conn)]))
-
-(define (channel-endpoints cname initial-message-producer)
-  (define inbound-stream-name (channel-stream-name #t cname))
-  (define outbound-stream-name (channel-stream-name #f cname))
-  (define (! conn message)
-    (transition conn (send-message (outbound-packet message))))
-  (list
-   (name-endpoint (list cname 'outbound)
-     (subscriber (channel-message outbound-stream-name (wild))
-       (match-state conn
-	 (on-presence (transition conn
-			(initial-message-producer inbound-stream-name outbound-stream-name)))
-	 (on-absence (maybe-close-channel cname conn 'local))
-	 (on-message
-	  [(channel-message _ body)
-	   (let ()
-	     (define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
-	     (define remote-ref (ssh-channel-remote-ref ch))
-	     (match body
-	       [(channel-stream-data data-bytes)
-		;; TODO: split data-bytes into packets if longer than max packet size
-		(! conn (ssh-msg-channel-data remote-ref data-bytes))]
-	       [(channel-stream-extended-data type data-bytes)
-		(! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))]
-	       [(channel-stream-eof)
-		(! conn (ssh-msg-channel-eof remote-ref))]
-	       [(channel-stream-notify type data-bytes)
-		(! conn (ssh-msg-channel-request remote-ref type #f data-bytes))]
-	       [(channel-stream-request type data-bytes)
-		(! conn (ssh-msg-channel-request remote-ref type #t data-bytes))]
-	       [(channel-stream-open-failure reason description)
-		(! (discard-channel cname conn)
-		   (ssh-msg-channel-open-failure remote-ref reason description #""))]))]))))
-   (name-endpoint (list cname 'inbound)
-     (publisher (channel-message inbound-stream-name (wild))
-       (match-state conn
-	 (on-message
-	  [(channel-message _ body)
-	   (let ()
-	     (define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
-	     (define remote-ref (ssh-channel-remote-ref ch))
-	     (match body
-	       [(channel-stream-config maximum-packet-size extra-data)
-		(if (channel-name-locally-originated? cname)
-		    ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN.
-		    (! conn (ssh-msg-channel-open (channel-name-type cname)
-						  (ssh-channel-local-ref ch)
-						  0
-						  maximum-packet-size
-						  extra-data))
-		    ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION.
-		    (! conn (ssh-msg-channel-open-confirmation remote-ref
-							       (ssh-channel-local-ref ch)
-							       0
-							       maximum-packet-size
-							       extra-data)))]
-	       [(channel-stream-credit count)
-		(! conn (ssh-msg-channel-window-adjust remote-ref count))]
-	       [(channel-stream-ok)
-		(! conn (ssh-msg-channel-success remote-ref))]
-	       [(channel-stream-fail)
-		(! conn (ssh-msg-channel-failure remote-ref))]))]))))))
-
-(define (channel-notify conn ch inbound? body)
-  (transition conn
-    (send-message (channel-message (channel-stream-name inbound? (ssh-channel-name ch))
-				   body)
-		  (if inbound? 'publisher 'subscriber))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Connection service
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (respond-to-opened-outbound-channel conn cname)
-  (if (and (ground? cname)
-	   (not (memf (ssh-channel-name=? cname) (connection-channels conn))))
-      (transition (update-channel cname values conn)
-	(channel-endpoints cname (lambda (inbound-stream outbound-stream)
-				   '())))
-      (transition conn)))
-
-(define (start-connection-service conn)
-  (sequence-actions
-      (transition
-	  (set-handlers conn
-			;; TODO: SSH_MSG_GLOBAL_REQUEST		handle-msg-global-request
-			SSH_MSG_CHANNEL_OPEN			handle-msg-channel-open
-			SSH_MSG_CHANNEL_OPEN_CONFIRMATION	handle-msg-channel-open-confirmation
-			SSH_MSG_CHANNEL_OPEN_FAILURE		handle-msg-channel-open-failure
-			SSH_MSG_CHANNEL_WINDOW_ADJUST		handle-msg-channel-window-adjust
-			SSH_MSG_CHANNEL_DATA			handle-msg-channel-data
-			SSH_MSG_CHANNEL_EXTENDED_DATA		handle-msg-channel-extended-data
-			SSH_MSG_CHANNEL_EOF			handle-msg-channel-eof
-			SSH_MSG_CHANNEL_CLOSE			handle-msg-channel-close
-			SSH_MSG_CHANNEL_REQUEST			handle-msg-channel-request
-			SSH_MSG_CHANNEL_SUCCESS			handle-msg-channel-success
-			SSH_MSG_CHANNEL_FAILURE			handle-msg-channel-failure))
-    ;; Start responding to channel interest coming from the
-    ;; application. We are responding to channels appearing from the
-    ;; remote peer by virtue of our installation of the handler for
-    ;; SSH_MSG_CHANNEL_OPEN above.
-    (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
-      (match-state conn
-	(match-conversation (channel-message (channel-stream-name #t cname) _)
-	  (on-presence (respond-to-opened-outbound-channel conn cname)))))
-    (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
-      (match-state conn
-	(match-conversation (channel-message (channel-stream-name #f cname) _)
-	  (on-presence (respond-to-opened-outbound-channel conn cname)))))))
-
-(define (handle-msg-channel-open packet message conn)
-  (match-define (ssh-msg-channel-open channel-type*
-				      remote-ref
-				      initial-window-size
-				      maximum-packet-size
-				      extra-request-data*)
-    message)
-
-  (when (memf (lambda (c) (equal? (ssh-channel-remote-ref c) remote-ref))
-	      (connection-channels conn))
-    (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
-			   "Attempt to open already-open channel ~v"
-			   remote-ref))
-
-  (define channel-type (bit-string->bytes channel-type*))
-  (define extra-request-data (bit-string->bytes extra-request-data*))
-  (define cname (channel-name #f channel-type remote-ref))
-
-  (transition (update-channel cname
-			      (lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref]))
-			      conn)
-    (channel-endpoints cname
-		       (lambda (inbound-stream outbound-stream)
-			 (list (send-feedback
-				(channel-message outbound-stream
-						 (channel-stream-config maximum-packet-size
-									extra-request-data)))
-			       (send-feedback
-				(channel-message outbound-stream
-						 (channel-stream-credit initial-window-size))))))))
-
-(define (handle-msg-channel-open-confirmation packet message conn)
-  (match-define (ssh-msg-channel-open-confirmation local-ref
-						   remote-ref
-						   initial-window-size
-						   maximum-packet-size
-						   extra-request-data*)
-    message)
-  (define ch (get-channel conn local-ref))
-  (define extra-request-data (bit-string->bytes extra-request-data*))
-  (define outbound-stream (channel-stream-name #f (ssh-channel-name ch)))
-  (transition (update-channel (ssh-channel-name ch)
-			      (lambda (c)
-				(struct-copy ssh-channel c
-					     [remote-ref remote-ref]
-					     [outbound-packet-size maximum-packet-size]))
-			      conn)
-    (send-feedback (channel-message outbound-stream
-				    (channel-stream-config maximum-packet-size
-							   extra-request-data)))
-    (send-feedback (channel-message outbound-stream
-				    (channel-stream-credit initial-window-size)))))
-
-(define (handle-msg-channel-open-failure packet message conn)
-  (match-define (ssh-msg-channel-open-failure local-ref
-					      reason
-					      description*
-					      _)
-    message)
-  (define ch (get-channel conn local-ref))
-  (define description (bit-string->bytes description*))
-  (define inbound-stream (channel-stream-name #t (ssh-channel-name ch)))
-  (sequence-actions (transition conn)
-    (send-message (channel-message inbound-stream
-				   (channel-stream-open-failure reason description)))
-    (lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote))))
-
-(define (handle-msg-channel-window-adjust packet message conn)
-  (match-define (ssh-msg-channel-window-adjust local-ref count) message)
-  (define ch (get-channel conn local-ref))
-  (channel-notify conn ch #f (channel-stream-credit count)))
-
-(define (handle-msg-channel-data packet message conn)
-  (match-define (ssh-msg-channel-data local-ref data*) message)
-  (define data (bit-string->bytes data*))
-  (define ch (get-channel conn local-ref))
-  (channel-notify conn ch #t (channel-stream-data data)))
-
-(define (handle-msg-channel-extended-data packet message conn)
-  (match-define (ssh-msg-channel-extended-data local-ref type-code data*) message)
-  (define data (bit-string->bytes data*))
-  (define ch (get-channel conn local-ref))
-  (channel-notify conn ch #t (channel-stream-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)))
-  (channel-notify conn ch #t (channel-stream-eof)))
-
-(define (handle-msg-channel-close packet message conn)
-  (define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message)))
-  (maybe-close-channel (ssh-channel-name ch) conn 'remote))
-
-(define (handle-msg-channel-request packet message conn)
-  (match-define (ssh-msg-channel-request local-ref type* want-reply? data*) message)
-  (define type (bit-string->bytes type*))
-  (define data (bit-string->bytes data*))
-  (define ch (get-channel conn local-ref))
-  (channel-notify conn ch #t
-		  (if want-reply?
-		      (channel-stream-request type data)
-		      (channel-stream-notify type data))))
-
-(define (handle-msg-channel-success packet message conn)
-  (match-define (ssh-msg-channel-success local-ref) message)
-  (define ch (get-channel conn local-ref))
-  (channel-notify conn ch #f (channel-stream-ok)))
-
-(define (handle-msg-channel-failure packet message conn)
-  (match-define (ssh-msg-channel-failure local-ref) message)
-  (define ch (get-channel conn local-ref))
-  (channel-notify conn ch #f (channel-stream-fail)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Session main process
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (connection-username conn)
-  (match (connection-authentication-state conn)
-    ((authenticated username servicename)
-     username)
-    (else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
-				 "Not authenticated"))))
-
-(define ((bump-total amount) conn)
-  (transition
-      (struct-copy connection conn
-		   [total-transferred (+ (connection-total-transferred conn) amount)])))
-
-;; (K V A -> A) A Hash<K,V> -> A
-(define (hash-fold fn seed hash)
-  (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 (maybe-rekey conn)
-  (define rekey (connection-rekey-state conn))
-  (if (time-to-rekey? rekey conn)
-      (let ((algs ((local-algorithm-list))))
-	(transition (struct-copy connection conn [rekey-state (rekey-local algs)])
-	  (send-message (outbound-packet algs))))
-      (transition conn)))
-
-;; 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 self-pid
-		     local-identification-string
-		     peer-identification-string
-		     application-boot
-		     session-role)
-  (transition (connection #f
-			  base-packet-dispatcher
-			  0
-			  (rekey-in-seconds-or-bytes -1 -1 0)
-			  #f
-			  '()
-			  (case session-role ((client) #f) ((server) #t))
-			  local-identification-string
-			  peer-identification-string
-			  #f
-			  application-boot)
-
-    (subscriber (timer-expired 'rekey-timer (wild))
-      (match-state conn
-	(on-message [(timer-expired 'rekey-timer now)
-		     (sequence-actions (transition conn)
-		       maybe-rekey)])))
-
-    (subscriber (outbound-byte-credit (wild))
-      (match-state conn
-	(on-message [(outbound-byte-credit amount)
-		     (sequence-actions (transition conn)
-		       (bump-total amount)
-		       maybe-rekey)])))
-
-    (subscriber (inbound-packet (wild) (wild) (wild) (wild))
-      (match-state conn
-	(on-message
-	 [(inbound-packet sequence-number payload message transfer-size)
-	  (sequence-actions (transition conn)
-	    (lambda (conn)
-	      (if (connection-discard-next-packet? conn)
-		  (transition
-		      (struct-copy connection conn [discard-next-packet? #f]))
-		  (dispatch-packet sequence-number payload message conn)))
-	    (bump-total transfer-size)
-	    (send-message (inbound-credit 1))
-	    maybe-rekey)])))))

ssh-transport.rkt

@@ -1,484 +0,0 @@
-#lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(require bitsyntax)
-(require (planet vyzo/crypto:2:3))
-
-(require racket/set)
-(require racket/match)
-
-(require rackunit)
-
-(require "aes-ctr.rkt")
-
-(require "ssh-numbers.rkt")
-(require "ssh-message-types.rkt")
-(require "ssh-exceptions.rkt")
-
-(require "marketplace-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
-	 local-algorithm-list
-
-	 ssh-reader
-	 ssh-writer)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data definitions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; A DecodedPacket is one of the packet structures defined in
-;; ssh-message-types.rkt.
-
-;; 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)
-	#:prefab)
-
-(struct crypto-configuration (cipher
-			      cipher-description
-			      hmac
-			      hmac-description)
-	#:transparent)
-
-;; Description of a supported cipher.
-(struct supported-cipher (name factory key-length block-size iv-length)
-	#:transparent)
-
-;; Description of a supported hmac algorithm.
-(struct supported-hmac (name factory digest-length key-length)
-	#:transparent)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Parameters
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define default-packet-limit (make-parameter 65536))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Encryption, MAC, and Compression algorithm descriptions and parameters
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; "none" cipher description.
-(define null-cipher-description
-  (supported-cipher 'none
-		    (lambda (enc? key iv)
-		      (lambda (block)
-			block))
-		    0
-		    8 ;; pseudo-block-size for packet I/O
-		    0))
-
-;; "none" HMAC function.
-(define (null-hmac blob)
-  #"")
-
-;; "none" HMAC description.
-(define null-hmac-description
-  (supported-hmac 'none
-		  (lambda (key)
-		    (error 'null-hmac-description
-			   "Cannot construct null hmac instance"))
-		  0
-		  0))
-
-(define (make-evp-cipher-entry name cipher)
-  (list name
-	(supported-cipher name
-			  (lambda (enc? key iv)
-			    (let ((state ((if enc? cipher-encrypt cipher-decrypt)
-					  cipher key iv #:padding #f)))
-			      (lambda (block)
-				(cipher-update! state block))))
-			  (cipher-key-length cipher)
-			  (cipher-block-size cipher)
-			  (cipher-iv-length cipher))))
-
-(define (aes-ctr-cipher-factory enc? key iv)
-  (let ((state (start-aes-ctr key iv)))
-    (lambda (block)
-      (aes-ctr-process! state block))))
-
-(define (make-aes-ctr-entry name key-length)
-  (list name
-	(supported-cipher name
-			  aes-ctr-cipher-factory
-			  key-length
-			  16
-			  16)))
-
-(define supported-crypto-algorithms
-  (list
-   (make-aes-ctr-entry 'aes128-ctr 16)
-   (make-aes-ctr-entry 'aes192-ctr 24)
-   (make-aes-ctr-entry 'aes256-ctr 32)
-   (make-evp-cipher-entry 'aes128-cbc cipher:aes-128-cbc)
-   (make-evp-cipher-entry 'aes192-cbc cipher:aes-192-cbc)
-   (make-evp-cipher-entry 'aes256-cbc cipher:aes-256-cbc)
-   (make-evp-cipher-entry '3des-cbc cipher:des-ede3)
-   )) ;; TODO: actually test these!
-
-(define (make-hmac-entry name digest key-length-or-false)
-  (let* ((digest-length (digest-size digest))
-	 (key-length (or key-length-or-false digest-length)))
-    (list name
-	  (supported-hmac name
-			  (lambda (key)
-			    (lambda (blob)
-			      (hmac digest key blob)))
-			  digest-length
-			  key-length))))
-
-(define supported-hmac-algorithms
-  (list (make-hmac-entry 'hmac-md5 digest:md5 #f)
-	(make-hmac-entry 'hmac-sha1 digest:sha1 #f)))
-
-(define supported-compression-algorithms '(none)) ;; TODO: zlib, and zlib delayed
-
-(define local-algorithm-list
-  (let ((crypto-names (map car supported-crypto-algorithms))
-	(mac-names (map car supported-hmac-algorithms)))
-    (make-parameter
-     (lambda ()
-       (ssh-msg-kexinit (random-bytes 16)
-			'(diffie-hellman-group14-sha1
-			  diffie-hellman-group1-sha1)
-			'(ssh-dss) ;; TODO: offer ssh-rsa. This will
-				   ;; involve replicating the tedious
-				   ;; crypto operations from the spec
-				   ;; rather than being able to use
-				   ;; the builtins from OpenSSL.
-			crypto-names
-			crypto-names
-			mac-names
-			mac-names
-			supported-compression-algorithms
-			supported-compression-algorithms
-			'()
-			'()
-			#f
-			0)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Cryptographic stream configuration
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define initial-crypto-configuration
-  (crypto-configuration #f
-			null-cipher-description
-			null-hmac
-			null-hmac-description))
-
-(define (apply-negotiated-options nk is-outbound?)
-  (match-define (new-keys is-server?
-			  derive-key
-			  c2s-enc s2c-enc
-			  c2s-mac s2c-mac
-			  c2s-zip s2c-zip) nk)
-  ;; TODO: zip
-  ;; TODO: make this less ugly. Compute all the keys, select just the ones we need afterward?
-  (define c2s
-    ;; c2s true iff stream is serverward
-    (if is-server? (not is-outbound?) is-outbound?))
-  (define enc (if c2s c2s-enc s2c-enc))
-  (define mac (if c2s c2s-mac s2c-mac))
-  (define zip (if c2s c2s-zip s2c-zip))
-
-  (define cipher-description
-    (cond
-     ((assq enc supported-crypto-algorithms) => cadr)
-     (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
-				  "Could not find driver for encryption algorithm ~v"
-				  enc))))
-  (define cipher
-    ((supported-cipher-factory cipher-description)
-     is-outbound?
-     (derive-key (if c2s #"C" #"D") (supported-cipher-key-length cipher-description))
-     (derive-key (if c2s #"A" #"B") (supported-cipher-iv-length cipher-description))))
-
-  (define hmac-description
-    (cond
-     ((assq mac supported-hmac-algorithms) => cadr)
-     (else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
-				  "Could not find driver for HMAC algorithm ~v"
-				  mac))))
-  (define hmac
-    ((supported-hmac-factory hmac-description)
-     (derive-key (if c2s #"E" #"F") (supported-hmac-key-length hmac-description))))
-
-  (crypto-configuration cipher cipher-description
-			hmac hmac-description))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Transport utilities
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; MacFunction Natural Bytes -> Bytes
-;; Computes the HMAC trailer for a given blob at the given sequence number.
-(define (apply-hmac mac sequence-number packet)
-  (mac (bit-string->bytes (bit-string-append (integer->bit-string sequence-number 32 #t)
-					     packet))))
-
-(define (check-packet-length! actual-length limit block-size)
-  (when (> actual-length limit)
-    (log-warning (format "Packet of length ~v exceeded our limit of ~v"
-			 actual-length
-			 limit)))
-  (when (> actual-length (* 2 limit))
-    ;; TODO: For some reason, OpenSSH seems to occasionally slightly
-    ;; exceed the packet size limit! (For example, sending a packet of
-    ;; length 65564 when I'm expecting a max of 65536.) So we actually
-    ;; enforce twice our actual limit.
-    (disconnect-with-error 0 ;; TODO: better reason code?
-			   "Packet of length ~v is longer than packet limit ~v"
-			   actual-length
-			   limit))
-  (when (not (zero? (modulo (+ actual-length 4) block-size)))
-    ;; the +4 is because the length sent on the wire doesn't include
-    ;; the length-of-length, but the requirements for transmitted
-    ;; chunks of data are that they be block-size multiples
-    ;; *including* the length-of-length
-    (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
-			   "Packet of length ~v is not a multiple of block size ~v"
-			   actual-length
-			   block-size)))
-
-;; Integer PositiveInteger -> Integer
-;; Rounds "what" up to the nearest multiple of "to".
-(define (round-up what to)
-  (* to (quotient (+ what (- to 1)) to)))
-
-(check-equal? (round-up 0 8) 0)
-(check-equal? (round-up 1 8) 8)
-(check-equal? (round-up 7 8) 8)
-(check-equal? (round-up 8 8) 8)
-(check-equal? (round-up 9 8) 16)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Encrypted Packet Input
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(struct ssh-reader-state (mode config sequence-number remaining-credit) #:prefab)
-
-(define (ssh-reader new-conversation)
-  (match-define (tcp-channel remote-addr local-addr _) new-conversation)
-  (define packet-size-limit (default-packet-limit))
-
-  (define (issue-credit state)
-    (match-define (ssh-reader-state _ (crypto-configuration _ desc _ _) _ message-credit) state)
-    (when (positive? message-credit)
-      (at-meta-level
-       (send-feedback (tcp-channel remote-addr local-addr
-				   (tcp-credit (supported-cipher-block-size desc)))))))
-
-  (transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0)
-    (at-meta-level
-     (name-endpoint 'socket-reader
-       (subscriber (tcp-channel remote-addr local-addr ?)
-	 (match-state (and state
-			   (ssh-reader-state mode
-					     (crypto-configuration cipher
-								   cipher-description
-								   hmac
-								   hmac-description)
-					     sequence-number
-					     remaining-credit))
-	   (on-message
-	    [(tcp-channel _ _ (? eof-object?))
-	     (transition state (quit))]
-	    [(tcp-channel _ _ (? bytes? encrypted-packet))
-	     (let ()
-	       (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 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
-			(send-feedback (tcp-channel remote-addr local-addr
-						    (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
-			 (send-feedback (tcp-channel remote-addr local-addr
-						     (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"))]))])))))
-    (subscriber (inbound-credit (wild))
-      (match-state state
-	(on-message
-	 [(inbound-credit amount)
-	  (let ()
-	    (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)))])))
-    (subscriber (new-keys (wild)
-			  (wild)
-			  (wild) (wild)
-			  (wild) (wild)
-			  (wild) (wild))
-      (match-state state
-	(on-message
-	 [(? new-keys? nk)
-	  (transition (struct-copy ssh-reader-state state
-			[config (apply-negotiated-options nk #f)]))])))
-    (publisher (inbound-packet (wild) (wild) (wild) (wild)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Encrypted Packet Output
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(struct ssh-writer-state (config sequence-number) #:prefab)
-
-(define (ssh-writer new-conversation)
-  (match-define (tcp-channel remote-addr local-addr _) new-conversation)
-  (transition (ssh-writer-state initial-crypto-configuration 0)
-    (publisher (outbound-byte-credit (wild)))
-    (subscriber (outbound-packet (wild))
-      (match-state (and state
-			(ssh-writer-state (crypto-configuration cipher
-								cipher-description
-								hmac
-								hmac-description)
-					  sequence-number))
-	(on-message
-	 [(outbound-packet message)
-	  (let ()
-	    (define pad-block-size (supported-cipher-block-size cipher-description))
-	    (define encryptor (if cipher cipher values))
-	    (define payload (ssh-message-encode message))
-	    ;; There must be at least 4 bytes of padding, and padding needs to
-	    ;; make the packet length a multiple of pad-block-size.
-	    (define unpadded-length (+ 4 ;; length of length
-				       1 ;; length of length-of-padding indicator
-				       (bit-string-byte-count payload)))
-	    (define min-padded-length (+ unpadded-length 4))
-	    (define padded-length (round-up min-padded-length pad-block-size))
-	    (define padding-length (- padded-length unpadded-length))
-	    (define packet-length (- padded-length 4))
-	    ;; ^^ the packet length does *not* include itself!
-	    (define packet (bit-string->bytes
-			    (bit-string (packet-length :: integer bits 32)
-					(padding-length :: integer bits 8)
-					(payload :: binary)
-					((random-bytes padding-length) :: binary))))
-	    (define encrypted-packet (encryptor packet))
-	    (define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
-	    (define mac-byte-count (bytes-length computed-hmac-bytes))
-	    (transition (struct-copy ssh-writer-state state
-			  [sequence-number (+ sequence-number 1)])
-	      (at-meta-level
-	       (send-message (tcp-channel local-addr remote-addr encrypted-packet)))
-	      (when (positive? mac-byte-count)
-		(at-meta-level
-		 (send-message (tcp-channel local-addr remote-addr computed-hmac-bytes))))
-	      (send-message
-	       (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count)))))])))
-    (subscriber (new-keys (wild)
-			  (wild)
-			  (wild) (wild)
-			  (wild) (wild)
-			  (wild) (wild))
-      (match-state state
-	(on-message
-	 [(? new-keys? nk)
-	  (transition
-	      (struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))))

syndicate-ssh/.gitignore

@@ -0,0 +1 @@
+schemas/

syndicate-ssh/cook-port.rkt

@@ -1,26 +1,11 @@
 #lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
 
+(require racket/match)
 (require racket/port)
 
-(provide cook-io)
+(provide cook-io cook-output)
 
 (define clear-to-eol "\033[2K")
 (define kill-line (string-append "\r" clear-to-eol))
@@ -68,33 +53,30 @@
    (lambda ()
      (define input-buffer (make-bytes 4096))
      (let loop ((b (buffer '() #f)))
-       (if (port-closed? cooked-in)
-	   ;; The ultimate reader of our cooked output has closed
-	   ;; their input port. We are therefore done.
-	   (close-ports)
-	   ;; TODO: remove polling for port-closed when we get port-closed-evt
-	   (let ((count (sync/timeout 0.5 (read-bytes-avail!-evt input-buffer raw-in))))
-	     (cond
-	      ((eof-object? count) ;; end-of-file on input
-	       (close-ports))
-	      ((eq? count #f) ;; timeout - poll to see if cooked-out has been closed
-	       (loop b))
-	      (else ;; a number - count of bytes read
-	       (let process-bytes ((i 0) (b b))
-		 (if (>= i count)
-		     (loop b)
-		     (update-buffer b (integer->char (bytes-ref input-buffer i)) prompt
-				    close-ports
-				    (lambda (line new-b)
-				      (with-handlers ((exn:fail? void)) ;; ignore write errors
-					(write-string "\r\n" raw-out))
-				      (write-string line cooked-out)
-				      (newline cooked-out)
-				      (process-bytes (+ i 1) new-b))
-				    (lambda (new-b feedback)
-				      (with-handlers ((exn:fail? void)) ;; ignore write errors
-					(write-string feedback raw-out))
-				      (process-bytes (+ i 1) new-b))))))))))))
+       (sync (handle-evt
+              (read-bytes-avail!-evt input-buffer raw-in)
+              (match-lambda
+                [(? eof-object?) ;; end-of-file on input
+                 (close-ports)]
+                [(? number? count)
+                 (let process-bytes ((i 0) (b b))
+                   (if (>= i count)
+                       (loop b)
+                       (update-buffer b (integer->char (bytes-ref input-buffer i)) prompt
+                                      close-ports
+                                      (lambda (line new-b)
+                                        (with-handlers ((exn:fail? void)) ;; ignore write errors
+                                          (write-string "\r\n" raw-out))
+                                        (write-string line cooked-out)
+                                        (newline cooked-out)
+                                        (process-bytes (+ i 1) new-b))
+                                      (lambda (new-b feedback)
+                                        (with-handlers ((exn:fail? void)) ;; ignore write errors
+                                          (write-string feedback raw-out))
+                                        (process-bytes (+ i 1) new-b)))))]))
+             (handle-evt
+              (port-closed-evt cooked-in)
+              (lambda (dummy) (close-ports)))))))
   (values cooked-in (cook-output raw-out)))
 
 (define (cook-output raw-out)

syndicate-ssh/crypto.rkt

@@ -0,0 +1,16 @@
+#lang racket/base
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(provide (all-from-out crypto)
+         (all-defined-out))
+
+(require crypto)
+(require crypto/all)
+(use-all-factories!)
+
+(define (sha1 bs)
+  (digest 'sha1 bs))
+
+(define (sha256 bs)
+  (digest 'sha256 bs))

syndicate-ssh/info.rkt

@@ -0,0 +1,23 @@
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+#lang setup/infotab
+(define collection "syndicate-ssh")
+
+(define deps '(
+
+	       "base"
+
+               "bitsyntax"
+               "crypto-lib"
+               "preserves"
+               "syndicate"
+
+               "unix-socket-lib"
+               "sandbox-lib"
+
+               ))
+
+(define build-deps '("rackunit-lib"))
+
+(define pre-install-collection "private/install.rkt")

syndicate-ssh/keys/ssh-agent.rkt

@@ -0,0 +1,91 @@
+#lang racket/base
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2018-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(require bitsyntax)
+(require racket/unix-socket)
+(require net/base64)
+
+(define-values (i o) (unix-socket-connect (getenv "SSH_AUTH_SOCK")))
+
+(define SSH_AGENT_FAILURE 5)
+(define SSH_AGENT_SUCCESS 6)
+(define SSH_AGENTC_REQUEST_IDENTITIES 11)
+(define SSH_AGENT_IDENTITIES_ANSWER 12)
+(define SSH_AGENTC_SIGN_REQUEST 13)
+(define SSH_AGENT_SIGN_RESPONSE 14)
+(define SSH_AGENTC_ADD_IDENTITY 17)
+(define SSH_AGENTC_REMOVE_IDENTITY 18)
+(define SSH_AGENTC_REMOVE_ALL_IDENTITIES 19)
+(define SSH_AGENTC_ADD_SMARTCARD_KEY 20)
+(define SSH_AGENTC_REMOVE_SMARTCARD_KEY 21)
+(define SSH_AGENTC_LOCK 22)
+(define SSH_AGENTC_UNLOCK 23)
+(define SSH_AGENTC_ADD_ID_CONSTRAINED 25)
+(define SSH_AGENTC_ADD_SMARTCARD_KEY_CONSTRAINED 26)
+(define SSH_AGENTC_EXTENSION 27)
+(define SSH_AGENT_EXTENSION_FAILURE 28)
+
+(struct identity (blob comment) #:transparent)
+
+(define (write-packet o type bs)
+  (write-bytes (bit-string->bytes
+                (bit-string ((+ 1 (bytes-length bs)) :: bits 32)
+                            (type :: bits 8)
+                            (bs :: binary)))
+               o)
+  (flush-output o))
+
+(define (read-packet i)
+  (bit-string-case (read-bytes 4 i)
+    ([(len :: bits 32)]
+     (bit-string-case (read-bytes len i)
+       ([(type :: bits 8) (body :: binary)]
+        (values type body))))))
+
+(define (list-keys i o)
+  (write-packet o SSH_AGENTC_REQUEST_IDENTITIES #"")
+  (define-values (response-type body) (read-packet i))
+  (when (not (= response-type SSH_AGENT_IDENTITIES_ANSWER))
+    (error 'list-keys "Invalid response from SSH agent: ~a" response-type))
+  (bit-string-case body
+    ([ (nkeys :: bits 32) (body :: binary) ]
+     (let loop ((acc-rev '()) (nkeys nkeys) (body body))
+       (if (zero? nkeys)
+           (reverse acc-rev)
+           (bit-string-case body
+             ([ (bloblen :: bits 32) (blob :: binary bytes bloblen)
+                (commentlen :: bits 32) (comment :: binary bytes commentlen)
+                (rest :: binary) ]
+              (loop (cons (identity (bit-string->bytes blob)
+                                    (bytes->string/utf-8 (bit-string->bytes comment)))
+                          acc-rev)
+                    (- nkeys 1)
+                    rest))))))))
+
+(define (blob-ed25519-key blob)
+  (bit-string-case blob
+    ([ (= 11 :: bits 32) (= #"ssh-ed25519" :: binary bytes 11)
+       (= 32 :: bits 32) (pk :: binary bytes 32) ]
+     (bit-string->bytes pk))
+    (else #f)))
+
+(define (sign data id i o)
+  (write-packet o SSH_AGENTC_SIGN_REQUEST
+                (bit-string->bytes
+                 (bit-string ((bytes-length (identity-blob id)) :: bits 32)
+                             ((identity-blob id) :: binary)
+                             ((bytes-length data) :: bits 32)
+                             (data :: binary)
+                             (0 :: bits 32))))
+  (define-values (response-type body) (read-packet i))
+  (when (not (= response-type SSH_AGENT_SIGN_RESPONSE))
+    (error 'sign "Invalid response from SSH agent: ~a" response-type))
+  (bit-string-case body
+    ([ (len :: bits 32) (signature :: binary bytes len) ]
+     (bit-string->bytes signature))))
+
+(let ((ids (filter (lambda (i) (blob-ed25519-key (identity-blob i))) (list-keys i o))))
+  (for-each writeln ids)
+  (newline)
+  )

syndicate-ssh/keys/ssh-keys.rkt

@@ -0,0 +1,110 @@
+#lang racket/base
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2018-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(provide file->ssh-private-key
+         bytes->ssh-private-key)
+
+(require racket/match)
+(require (only-in racket/file file->bytes))
+(require (only-in racket/port call-with-input-bytes))
+(require (only-in racket/string string-join))
+
+(require net/base64)
+(require bitsyntax)
+;; (require blowfish/bcrypt-hash)
+(require crypto)
+
+(require "../ssh-message-types.rkt")
+
+(define (file->ssh-private-key filename [passphrase-bytes #f])
+  (bytes->ssh-private-key (file->bytes filename) passphrase-bytes))
+
+(define (bytes->ssh-private-key bs [passphrase-bytes #f])
+  (call-with-input-bytes
+   bs
+   (lambda (p)
+     (and (equal? (read-line p) "-----BEGIN OPENSSH PRIVATE KEY-----")
+          (let ((blob (let collect ((acc '()))
+                        (match (read-line p)
+                          ["-----END OPENSSH PRIVATE KEY-----"
+                           (base64-decode (string->bytes/latin-1 (string-join (reverse acc))))]
+                          [line
+                           (collect (cons line acc))]))))
+            (bit-string-case blob
+              ([ (= #"openssh-key-v1\0" :: binary bytes 15)
+                 (ciphername :: (t:string #:pack))
+                 (kdfname :: (t:string #:pack))
+                 (kdfoptions :: (t:string #:pack))
+                 (= 1 :: bits 32) ;; OpenSSH only supports one key
+                 (public-keys :: (t:repeat 1 (t:string #:pack)))
+                 (private-keys :: (t:string #:pack)) ]
+               (decode-private-keys passphrase-bytes
+                                    ciphername
+                                    kdfname
+                                    kdfoptions
+                                    (car public-keys)
+                                    private-keys))
+              (else #f)))))))
+
+(define (decode-private-keys passphrase-bytes
+                             ciphername
+                             kdfname
+                             kdfoptions
+                             public-key
+                             private-keys)
+  (define pk-bytes
+    (bit-string-case public-key
+      ([ (= #"ssh-ed25519" :: (t:string #:pack))
+         (bs :: (t:string #:pack)) ]
+       bs)))
+  (define (decode-decrypted blob)
+    ;; Oddly, this only partially lines up with the spec at
+    ;; https://cvsweb.openbsd.org/cgi-bin/cvsweb/src/usr.bin/ssh/PROTOCOL.key?annotate=1.1
+    ;;
+    ;; Specifically, contra spec, after the checkints, we seem to have
+    ;; the public key again followed by the private key bytes and then
+    ;; a comment string.
+    ;;
+    ;; The code (sshkey.c) does this:
+    ;;  - retrieve a key type string
+    ;;  - dispatch on it
+    ;;  - for ed25519, read a string with the PK, then a string with the SK
+    ;;  - checks the sizes to ensure they are correct for ed25519
+    ;;
+    ;; This is what the PROTOCOL.key documentation says to do. It's
+    ;; not what actually needs to be done.
+    ;;
+    ;; [ (checkint1 :: bits 32) (= checkint1 :: bits 32) ;; must be the same
+    ;;   (keys :: (t:repeat 1 (t:repeat 2 (t:string #:pack))))
+    ;;   (= 'padding-ok :: (t:padding)) ]
+    ;;
+    (bit-string-case blob
+      ([ (checkint1 :: bits 32) (= checkint1 :: bits 32) ;; must be the same
+         (= #"ssh-ed25519" :: (t:string #:pack))
+         (pk-bytes-in-sk :: (t:string #:pack))
+         (sk :: (t:string #:pack))
+         (comment :: (t:string #:pack))
+         (= 'padding-ok :: (t:padding))
+         ]
+       (and (equal? pk-bytes pk-bytes-in-sk)
+            (list pk-bytes sk (bytes->string/utf-8 comment))))
+      (else #f)))
+  (match* (ciphername kdfname)
+    [(#"none" #"none")
+     (decode-decrypted private-keys)]
+    ;; This stanza works, I just don't want to depend on bcrypt just yet:
+    #;[(#"aes256-ctr" #"bcrypt")
+     (define keylen (/ 256 8)) ;; aes256 = 256 bit key length
+     (define ivlen (/ 128 8)) ;; fixed block size of 128 bits
+     (bit-string-case kdfoptions
+       ([ (salt :: (t:string #:pack))
+          (rounds :: bits 32) ]
+        (when (not passphrase-bytes) (error 'read-ssh-private-key "Passphrase required"))
+        (bit-string-case (bcrypt-pbkdf passphrase-bytes salt (+ keylen ivlen) rounds)
+          ([ (key :: binary bytes keylen) (iv :: binary bytes ivlen) ]
+           (decode-decrypted
+            (parameterize ((crypto-factories (list libcrypto-factory)))
+              (decrypt '(aes ctr) (bit-string->bytes key) (bit-string->bytes iv) private-keys)))))))]
+    [(_ _)
+     (error 'read-ssh-private-key "Unsupported private-key cipher/kdf")]))

syndicate-ssh/mapping.rkt

@@ -1,22 +1,6 @@
 #lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
 
 (provide define-mapping)
 

syndicate-ssh/new-server.rkt

@@ -0,0 +1,181 @@
+#lang syndicate
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+;;; (Temporary) example client and server
+
+(require syndicate/drivers/racket-event)
+(require syndicate/drivers/timer)
+(require syndicate/drivers/tcp)
+(require syndicate/driver-support)
+(require syndicate/dataspace)
+(require syndicate/pattern)
+
+(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 "ssh-keys.rkt")
+(require "schemas/channel.rkt")
+(require "schemas/auth.rkt")
+
+(module+ main
+  (standard-actor-system (ds)
+    (define spec (TcpLocal "0.0.0.0" 29418))
+    (at ds
+      (stop-on (asserted (StreamListenerError spec $message)))
+      (during/spawn (StreamConnection $source $sink spec)
+        #:name (list 'ssh source)
+        (session ds source sink (load-private-key "test-host-keys/ssh_host_ed25519_key"))))
+    ))
+
+;; (define host-key-ed25519-public (pk-key->public-only-key host-key-ed25519-private))
+
+(define test-user-private (load-private-key "test-user-key"))
+(define test-user-public (load-public-key "test-user-key.pub"))
+
+;;---------------------------------------------------------------------------
+
+(define (session ground-ds source sink host-private-key)
+  (on-stop (log-info "Session VM for ~a closed" source))
+  (actor-group
+    #:link? #t
+    (define conn-ds (dataspace #:name (gensym 'conn-ds)))
+
+    (define local-identification #"SSH-2.0-RacketSSH_0.0")
+
+    (spawn/link #:name 'reader (ssh-reader conn-ds ground-ds source))
+    (spawn/link #:name 'writer (ssh-writer conn-ds sink local-identification))
+
+    (on-stop (stop-actor-system))
+
+    (at conn-ds
+      (once
+       [(message (ssh-identification-line $remote-identification))
+        (cond
+          [(regexp-match #rx"^SSH-2\\.0-.*" remote-identification)
+           (send! (inbound-credit 1))
+           (spawn
+             #:name 'session
+             (ssh-session conn-ds
+                          ground-ds
+                          local-identification
+                          remote-identification
+                          'server
+                          host-private-key))]
+          [else
+           (log-error "Invalid peer identification string ~v" remote-identification)
+           (stop-actor-system)])])
+
+      (define (auth-method m f)
+        (assert (SshAuthenticationMethodAcceptable m))
+        (during (Observe (:pattern (SshAuthenticationAcceptable m ,(DLit $r) ,_)) _)
+          (assert (SshAuthenticationAcceptable m r (f (parse-SshAuthRequest r))))))
+
+      (auth-method (SshAuthMethod-none)
+                   (match-lambda [(SshAuthRequest-none "guest") #t]
+                                 [_ #f]))
+      (auth-method (SshAuthMethod-password)
+                   (match-lambda [(SshAuthRequest-password "user" "password") #t]
+                                 [_ #f]))
+      (auth-method (SshAuthMethod-publickey)
+                   (match-lambda [(SshAuthRequest-publickey "tonyg" key)
+                                  (equal? (->preserve key)
+                                          (public-key->pieces test-user-public))]
+                                 [_ #f]))
+
+      (during (SshAuthenticatedUser $user-name #"ssh-connection")
+        (run-repl-instance conn-ds user-name))
+
+      (on (asserted (protocol-error $reason-code $message _ $originated-at-peer?))
+        (when (not originated-at-peer?)
+          (send! (outbound-packet (ssh-msg-disconnect reason-code
+                                                      (string->bytes/utf-8 message)
+                                                      #""))))
+        (sync! conn-ds (stop-actor-system))))))
+
+;;---------------------------------------------------------------------------
+
+
+(define (run-repl-instance conn-ds user-name)
+  (on-start (log-info "~s connected" user-name))
+  (on-stop (log-info "~s disconnected" user-name))
+
+  (at conn-ds
+    (assert (SshChannelTypeAvailable #"session"))
+    (during (StreamConnection $source $sink (SshChannelLocal #"session" _))
+      ;; c2s-in     used by repl to read input from channel
+      ;; c2s-out    used by channel to feed input from remote to the repl
+      ;; s2c-in     used by channel to feed output from repl to remote
+      ;; s2c-out    used by repl to write output to channel
+      (define-values (c2s-in c2s-out) (make-pipe))
+      (define-values (s2c-in s2c-out) (make-pipe))
+      (define-values (s2c-err-in s2c-err-out) (make-pipe))
+      (on-stop (close-input-port c2s-in)
+               (close-output-port c2s-out)
+               (close-input-port s2c-in)
+               (close-output-port s2c-out)
+               (close-input-port s2c-err-in)
+               (close-output-port s2c-err-out))
+
+      (define (handle-data data mode)
+        (match mode
+          [(Mode-bytes)
+           (write-bytes data c2s-out)
+           (flush-output c2s-out)
+           (send-bytes-credit source (bytes-length data))]
+          [(Mode-object (:parse (SshChannelObject-extendedData type-code)))
+           (match type-code
+             [SSH_EXTENDED_DATA_STDERR
+              (log-info "2> ~s" data)]
+             [_
+              (log-warning "Ignoring extended data type-code ~s: ~s" type-code data)])
+           (send-bytes-credit source (bytes-length data))]
+          [(Mode-object (:parse (SshChannelObject-request type want-reply)))
+           (define ok? (handle-request type))
+           (when want-reply
+             (define reply (if ok? (SshChannelObject-success) (SshChannelObject-failure)))
+             (send-data sink #"" (Mode-object reply)))]))
+
+      (define (handle-eof)
+        (close-output-port c2s-out))
+
+      (define (handle-request type)
+        (match type
+          [#"pty-req"
+           (define-values (cooked-c2s-in cooked-s2c-out) (cook-io c2s-in s2c-out "> "))
+           (set! c2s-in cooked-c2s-in)
+           (set! s2c-out cooked-s2c-out)
+           (set! s2c-err-out (cook-output s2c-err-out))
+           #t]
+          [#"env"
+           ;; Don't care
+           ;; TODO: care?
+           #t]
+          [#"shell"
+           (make-sink #:initial-source (port-source s2c-in)
+                      #:on-connect (lambda (s) (send-credit s (CreditAmount-unbounded) (Mode-bytes)))
+                      #:on-data (lambda (data _mode) (send-data sink data))
+                      #:on-eof (lambda () (stop-current-facet)))
+           (make-sink #:initial-source (port-source s2c-err-in)
+                      #:on-connect (lambda (s) (send-credit s (CreditAmount-unbounded) (Mode-bytes)))
+                      #:on-data (lambda (data _mode)
+                                  (send-data sink data
+                                             (Mode-object (SshChannelObject-extendedData
+                                                           SSH_EXTENDED_DATA_STDERR)))))
+           (linked-thread #:name 'repl
+                          (lambda (_facet)
+                            (repl-shell user-name c2s-in s2c-out s2c-err-out)))
+           #t]
+          [_
+           (log-warning "Unsupported channel request type ~s" type)
+           #f]))
+
+      (handle-connection source sink #:initial-credit #f #:on-data handle-data #:on-eof handle-eof)
+      (assert (SshChannelOpenResponse-ok sink #"")))))

syndicate-ssh/oakley-groups.rkt

@@ -0,0 +1,30 @@
+#lang racket/base
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+;; Construct Oakley MODP Diffie-Hellman groups from RFCs 2409 and 3526.
+
+(provide dh:oakley-group-2
+	 dh:oakley-group-14)
+
+(require "crypto.rkt")
+
+(require (only-in net/base64 base64-decode))
+
+(define dh:oakley-group-2
+  (datum->pk-parameters
+   (base64-decode
+    #"MIGHAoGBAP//////////yQ/aoiFowjTExmKLgNwc0SkCTgiKZ8x0Agu+pjsTmyJRSgh5jjQE
+      3e+VGbPNOkMbMCsKbfJfFDdP4TVtbVHCReSFtXZiXn7G9ExC6aY37WsL/1y29Aa37e44a/ta
+      iZ+lrp8kEXxLH+ZJKGZR7OZTgf//////////AgEC")
+   'DHParameter))
+
+(define dh:oakley-group-14
+  (datum->pk-parameters
+   (base64-decode
+    #"MIIBCAKCAQEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmO
+      NATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr
+      +1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYc
+      YvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aei
+      j7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqsqmj//////////wIBAg==")
+   'DHParameter))

syndicate-ssh/private/install.rkt

@@ -0,0 +1,29 @@
+#lang racket/base
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(provide pre-installer)
+
+(require racket/runtime-path)
+(require preserves-schema/bin/preserves-schema-rkt)
+(require (only-in racket/file delete-directory/files))
+
+(require (only-in syndicate/schema-compiler
+                  schema-compiler-plugin
+                  schema-compiler-plugin-mode))
+
+(define (pre-installer _collects-path package-path)
+  (define output-directory (build-path package-path "schemas"))
+  (delete-directory/files output-directory #:must-exist? #f)
+  (batch-compile #:inputs (list (build-path package-path "../protocols/schemas/**.prs"))
+                 #:additional-modules (hash '(EntityRef) 'syndicate/entity-ref)
+                 #:output-directory output-directory
+                 #:plugins (list schema-compiler-plugin)))
+
+(define-runtime-path package-path "..")
+(define (regenerate!)
+  (void (pre-installer 'not-bothering-to-figure-this-out-since-we-do-not-need-it
+                       package-path)))
+
+(module+ main
+  (regenerate!))

syndicate-ssh/sandboxes.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+;;; Sandbox management and use.
+
+(require racket/match)
+(require racket/sandbox)
+(require (only-in racket/exn exn->string))
+
+(provide repl-shell)
+
+(struct user-state (name primary-sandbox primary-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 [err out])
+  (match-define (user-state _ primary-sandbox primary-namespace) (get-user-state username))
+  (parameterize ((current-input-port in)
+		 (current-output-port out)
+		 (current-error-port err)
+		 (sandbox-input in)
+		 (sandbox-output out)
+		 (sandbox-error-output err)
+		 (sandbox-memory-limit 2) ;; megabytes
+		 (sandbox-eval-limits #f)
+		 (sandbox-namespace-specs (list (lambda () primary-namespace))))
+    (printf "Hello, ~a.\n" username)
+    (define secondary-sandbox (make-evaluator '(begin)))
+    ;; ^^ uses primary-namespace via sandbox-namespace-specs
+    (parameterize ((current-namespace primary-namespace)
+		   (current-eval secondary-sandbox))
+      (let restart ()
+        (with-handlers ([exn?
+                         (lambda (e)
+                           (fprintf err "~a" (exn->string e))
+                           (flush-output err)
+                           (restart))])
+          (read-eval-print-loop))))
+    (fprintf out "\nGoodbye!\n")
+    (kill-evaluator secondary-sandbox)
+    (close-input-port in)
+    (close-output-port out)
+    (close-output-port err)))

syndicate-ssh/ssh-channel.rkt

@@ -1,22 +1,6 @@
 #lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
 
 (require racket/set)
 (require racket/match)

syndicate-ssh/ssh-exceptions.rkt

@@ -0,0 +1,42 @@
+#lang syndicate
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+;;; Error-raising and -handling utilities used in structuring SSH sessions.
+
+(provide (struct-out protocol-error)
+	 disconnect-with-error
+	 disconnect-with-error/local-info
+	 disconnect-with-error*)
+
+;; A `protocol-error`, when asserted, will cause a SSH_MSG_DISCONNECT
+;; to be sent to the remote party with the included reason code, using
+;; `message` as the description. The `local-info` field is useful
+;; information for diagnosing problems known to the local stack that
+;; should not be transmitted to the remote party. For example, upon
+;; detection of a MAC failure, it might be useful to know the expected
+;; and actual MACs for debugging, but they should not be sent over the
+;; wire because we could be experiencing some kind of attack.
+(struct protocol-error (reason-code message local-info originated-at-peer?) #:prefab)
+
+;; DS Natural FormatString [Any ...] -> signalled protocol-error
+(define (disconnect-with-error ds reason-code format-string . args)
+  (apply disconnect-with-error* ds #f '() reason-code format-string args))
+
+;; DS Any Natural FormatString [Any ...] -> signalled protocol-error
+(define (disconnect-with-error/local-info ds local-info reason-code format-string . args)
+  (apply disconnect-with-error* ds #f local-info reason-code format-string args))
+
+;; DS Boolean Any Natural FormatString [Any ...] -> signalled protocol-error
+(define (disconnect-with-error* ds
+                                originated-at-peer?
+				local-info
+				reason-code
+				format-string
+				. args)
+  (define message (apply format format-string args))
+  (escape-pod
+   (lambda ()
+     (spawn #:name (list 'protocol-error reason-code message)
+            (at ds (assert (protocol-error reason-code message local-info originated-at-peer?))))))
+  (error 'protocol-error "(~a) ~a: ~v" reason-code message local-info))

syndicate-ssh/ssh-keys.rkt

@@ -0,0 +1,99 @@
+#lang racket/base
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(provide (struct-out ed25519-private-key)
+         (struct-out ed25519-public-key)
+
+	 public-key->pieces
+	 pieces->public-key
+
+	 make-key-signature
+	 verify-key-signature!
+
+	 pieces->ssh-key
+	 ssh-key->pieces
+
+         load-private-key
+         load-public-key)
+
+(require racket/match)
+(require racket/port)
+(require net/base64)
+(require (only-in racket/file file->bytes file->string))
+
+(require bitsyntax)
+(require "crypto.rkt")
+(require "keys/ssh-keys.rkt")
+(require "ssh-message-types.rkt")
+
+(module+ test (require rackunit))
+
+(struct ed25519-private-key (q d) #:prefab)
+(struct ed25519-public-key (q) #:prefab)
+
+(define (bytes->private-key-pieces bs)
+  (match (bytes->ssh-private-key bs)
+    [(list pk-bytes sk-bytes _comment)
+     (ed25519-private-key pk-bytes sk-bytes)]))
+
+(define (pieces->private-key p)
+  (match p
+    [(ed25519-private-key q d)
+     (datum->pk-key (list 'eddsa 'private 'ed25519 q d) 'rkt-private)]))
+
+(define (public-key->pieces key)
+  (match (pk-key->datum key 'rkt-public)
+    [(list 'eddsa 'public 'ed25519 q)
+     (ed25519-public-key q)]))
+
+(define (pieces->public-key p)
+  (match p
+    [(ed25519-public-key q)
+     (datum->pk-key (list 'eddsa 'public 'ed25519 q) 'rkt-public)]))
+
+(define (make-key-signature private-key key-alg exchange-hash)
+  (match key-alg
+    [#"ssh-ed25519"
+     (define signature (pk-sign private-key exchange-hash))
+     (bit-string (#"ssh-ed25519" :: (t:string))
+                 (signature :: (t:string)))]))
+
+(define (verify-key-signature! public-key key-alg exchange-hash h-signature)
+  ;; TODO: If we are *re*keying, worth checking here that the key hasn't *changed* either.
+  (write `(TODO check-key!)) (newline) (flush-output) ;; actually check the identity TOFU/POP
+  (match key-alg
+    [#"ssh-ed25519"
+     (define signature (bit-string-case h-signature
+                         ([ (= #"ssh-ed25519" :: (t:string #:pack))
+                            (sig :: (t:string #:pack)) ]
+                          sig)))
+     (when (not (pk-verify public-key exchange-hash signature))
+       (error 'verify-key-signature! "Signature mismatch"))]))
+
+(define (pieces->ssh-key pieces)
+  (match pieces
+    [(ed25519-public-key q)
+     (bit-string (#"ssh-ed25519" :: (t:string))
+                 (q :: (t:string)))]))
+
+(define (ssh-key->pieces key-alg blob)
+  (match key-alg
+    [#"ssh-ed25519" (bit-string-case blob
+                      ([ (= #"ssh-ed25519" :: (t:string #:pack))
+                         (q :: (t:string #:pack)) ]
+                       (ed25519-public-key q))
+                      (else #f))]
+    [_ #f]))
+
+;; TODO: proper store for keys
+
+(define (load-private-key filename)
+  (pieces->private-key (bytes->private-key-pieces (file->bytes filename))))
+
+(define (load-public-key filename)
+  (match (file->string filename)
+    [(pregexp #px"ssh-ed25519 +(\\S+) +([^\n]*)\n$" (list _ data-base64 _comment))
+     (pieces->public-key (ssh-key->pieces #"ssh-ed25519"
+                                          (base64-decode (string->bytes/utf-8 data-base64))))]
+    [_ (error 'load-public-key "Cannot load key in file ~s" filename)]))

syndicate-ssh/ssh-message-types.rkt

@@ -1,44 +1,21 @@
 #lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(require "ssh-numbers.rkt")
-
-(require (for-syntax racket/base))
-(require (for-syntax (only-in racket/list append*)))
-(require (for-syntax (only-in srfi/1 iota)))
-
-(require bitsyntax)
-(require racket/bytes)
-
-(require rackunit)
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
 
 (provide ssh-message-decode
 	 ssh-message-encode)
 
 (provide t:boolean
 	 t:string
+	 t:string/utf-8
 	 t:mpint
 	 mpint-width
-	 t:name-list)
+	 t:name-list
+         t:repeat
+         t:padding)
 
-(provide (struct-out ssh-msg-kexinit)
+(provide (struct-out ssh-identification-line)
+         (struct-out ssh-msg-kexinit)
 	 (struct-out ssh-msg-kexdh-init)
 	 (struct-out ssh-msg-kexdh-reply)
 	 (struct-out ssh-msg-disconnect)
@@ -51,6 +28,8 @@
 	 (struct-out ssh-msg-userauth-request)
 	 (struct-out ssh-msg-userauth-failure)
 	 (struct-out ssh-msg-userauth-success)
+	 (struct-out ssh-msg-userauth-banner)
+	 (struct-out ssh-msg-userauth-pk-ok)
 	 (struct-out ssh-msg-global-request)
 	 (struct-out ssh-msg-request-success)
 	 (struct-out ssh-msg-request-failure)
@@ -67,6 +46,16 @@
 	 (struct-out ssh-msg-channel-failure)
 	 )
 
+(require "ssh-numbers.rkt")
+
+(require (for-syntax racket/base))
+(require (for-syntax (only-in racket/list append*)))
+
+(require bitsyntax)
+(require racket/bytes)
+
+(module+ test (require rackunit))
+
 (define encoder-map (make-hasheqv))
 (define decoder-map (make-hasheqv))
 
@@ -128,6 +117,13 @@
      (bit-string ((bytes-length (bit-string->bytes bs)) :: integer bits 32)
 		 (bs :: binary)))))
 
+(define-syntax t:string/utf-8
+  (syntax-rules ()
+    ((_ #t input ks kf)
+     (t:string #t input (lambda (v rest) (ks (bytes->string/utf-8 v) rest)) kf #:pack))
+    ((_ #f str)
+     (t:string #f (string->bytes/utf-8 str) #:pack))))
+
 (define-syntax t:mpint
   (syntax-rules ()
     ((_ #t input ks kf)
@@ -151,14 +147,44 @@
     ((_ #f ns)
      (t:string #f (symbols->name-list ns)))))
 
+(define-syntax t:repeat
+  (syntax-rules ()
+    [(_ #t input ks kf parser)
+     (let loop ((acc-rev '()) (rest input))
+       (bit-string-case rest
+         ([ (item :: parser) (rest :: binary) ] (loop (cons item acc-rev) rest))
+         (else (ks (reverse acc-rev) rest))))]
+    [(_ #t input ks kf ntimes parser)
+     (let loop ((acc-rev '()) (rest input) (n ntimes))
+       (if (zero? n)
+           (ks (reverse acc-rev) rest)
+           (bit-string-case rest
+             ([ (item :: parser) (rest :: binary) ]
+              (loop (cons item acc-rev) rest (- n 1))))))]
+    [(_ #f items0 parser)
+     (let loop ((items items0))
+       (match items
+         ['() #""]
+         [(cons item items) (bit-string (item :: parser) (loop items))]))]))
+
+(define-syntax t:padding
+  (syntax-rules ()
+    [(_ #t input ks kf)
+     (let loop ((expected 1) (rest input))
+       (bit-string-case rest
+         ([ (= expected) (rest :: binary) ] (loop (+ expected 1) rest))
+         ([ ] (ks 'padding-ok #""))
+         (else (kf))))]))
+
 (define-for-syntax (codec-options field-type)
-  (syntax-case field-type (byte boolean uint32 uint64 string mpint name-list)
+  (syntax-case field-type (byte boolean uint32 uint64 string string/utf-8 mpint name-list extension)
     (byte #'(integer bits 8))
     ((byte n) #'((t:packed-bytes n)))
     (boolean #'((t:boolean)))
     (uint32 #'(integer bits 32))
     (uint64 #'(integer bits 64))
     (string #'((t:string #:pack)))
+    (string/utf-8 #'((t:string/utf-8)))
     (mpint #'((t:mpint)))
     (name-list #'((t:name-list)))
     (extension #'((t:packed-bytes)))))
@@ -170,11 +196,9 @@
        #`(lambda (message)
 	   (let ((vec (struct->vector message)))
 	     #,(with-syntax (((field-spec ...)
-			      (let ((type-list (syntax->list #'(field-type ...))))
-				(map (lambda (index type)
-				       #`((vector-ref vec #,index) :: #,@(codec-options type)))
-				     (iota (length type-list) 1)
-				     type-list))))
+                              (for/list [(index (in-naturals 1))
+                                         (type (in-list (syntax->list #'(field-type ...))))]
+                                #`((vector-ref vec #,index) :: #,@(codec-options type)))))
 		 #'(bit-string (type-byte-value :: integer bytes 1)
 			       field-spec ...))))))))
 
@@ -195,16 +219,17 @@
       0
       (+ 1 (quotient (integer-length n) 8))))
 
-(check-eqv? (mpint-width 0) 0)
-(check-eqv? (mpint-width #x9a378f9b2e332a7) 8)
-(check-eqv? (mpint-width #x7f) 1)
-(check-eqv? (mpint-width #x80) 2)
-(check-eqv? (mpint-width #x81) 2)
-(check-eqv? (mpint-width #xff) 2)
-(check-eqv? (mpint-width #x100) 2)
-(check-eqv? (mpint-width #x101) 2)
-(check-eqv? (mpint-width #x-1234) 2)
-(check-eqv? (mpint-width #x-deadbeef) 5)
+(module+ test
+  (check-eqv? (mpint-width 0) 0)
+  (check-eqv? (mpint-width #x9a378f9b2e332a7) 8)
+  (check-eqv? (mpint-width #x7f) 1)
+  (check-eqv? (mpint-width #x80) 2)
+  (check-eqv? (mpint-width #x81) 2)
+  (check-eqv? (mpint-width #xff) 2)
+  (check-eqv? (mpint-width #x100) 2)
+  (check-eqv? (mpint-width #x101) 2)
+  (check-eqv? (mpint-width #x-1234) 2)
+  (check-eqv? (mpint-width #x-deadbeef) 5))
 
 (define (symbols->name-list syms)
   (bytes-join (map (lambda (s) (string->bytes/utf-8 (symbol->string s))) syms) #","))
@@ -214,29 +239,32 @@
       '()
       (map string->symbol (regexp-split #rx"," (bytes->string/utf-8 (bit-string->bytes bs))))))
 
-(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 (bit-string->bytes (test-encode msg)))
-	    (enc-msg (test-decode enc)))
-	(if (and (equal? msg-enc enc)
-		 (equal? enc-msg msg))
-	    'ok
-	    `(fail ,msg-enc ,enc-msg)))))
-  (check-eqv? (bidi-check (test-message 0) (bytes 0 0 0 0)) 'ok)
-  (check-eqv? (bidi-check (test-message #x9a378f9b2e332a7)
-			  (bytes #x00 #x00 #x00 #x08
-				 #x09 #xa3 #x78 #xf9
-				 #xb2 #xe3 #x32 #xa7)) 'ok)
-  (check-eqv? (bidi-check (test-message #x80)
-			  (bytes #x00 #x00 #x00 #x02 #x00 #x80)) 'ok)
-  (check-eqv? (bidi-check (test-message #x-1234)
-			  (bytes #x00 #x00 #x00 #x02 #xed #xcc)) 'ok)
-  (check-eqv? (bidi-check (test-message #x-deadbeef)
-			  (bytes #x00 #x00 #x00 #x05
-				 #xff #x21 #x52 #x41 #x11)) 'ok))
+(module+ test
+  (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 (bit-string->bytes (test-encode msg)))
+              (enc-msg (test-decode enc)))
+          (if (and (equal? msg-enc enc)
+                   (equal? enc-msg msg))
+              'ok
+              `(fail ,msg-enc ,enc-msg)))))
+    (check-eqv? (bidi-check (test-message 0) (bytes 0 0 0 0)) 'ok)
+    (check-eqv? (bidi-check (test-message #x9a378f9b2e332a7)
+                            (bytes #x00 #x00 #x00 #x08
+                                   #x09 #xa3 #x78 #xf9
+                                   #xb2 #xe3 #x32 #xa7)) 'ok)
+    (check-eqv? (bidi-check (test-message #x80)
+                            (bytes #x00 #x00 #x00 #x02 #x00 #x80)) 'ok)
+    (check-eqv? (bidi-check (test-message #x-1234)
+                            (bytes #x00 #x00 #x00 #x02 #xed #xcc)) 'ok)
+    (check-eqv? (bidi-check (test-message #x-deadbeef)
+                            (bytes #x00 #x00 #x00 #x05
+                                   #xff #x21 #x52 #x41 #x11)) 'ok)))
+
+(struct ssh-identification-line (bytes) #:prefab)
 
 (define-ssh-message-type ssh-msg-kexinit SSH_MSG_KEXINIT
      ((byte 16)    cookie)
@@ -290,9 +318,9 @@
   (string service-name))
 
 (define-ssh-message-type ssh-msg-userauth-request SSH_MSG_USERAUTH_REQUEST
-  (string    user-name)
-  (string    service-name)
-  (string    method-name)
+  (string/utf-8 user-name)
+  (string       service-name)
+  (string       method-name)
   (extension method-specific-fields))
 
 (define-ssh-message-type ssh-msg-userauth-failure SSH_MSG_USERAUTH_FAILURE
@@ -301,6 +329,14 @@
 
 (define-ssh-message-type ssh-msg-userauth-success SSH_MSG_USERAUTH_SUCCESS)
 
+(define-ssh-message-type ssh-msg-userauth-banner SSH_MSG_USERAUTH_BANNER
+  (string/utf-8 message)
+  (string       language))
+
+(define-ssh-message-type ssh-msg-userauth-pk-ok SSH_MSG_USERAUTH_PK_OK
+  (string    algorithm-name)
+  (string    pk-blob))
+
 (define-ssh-message-type ssh-msg-global-request SSH_MSG_GLOBAL_REQUEST
   (string    request-name)
   (boolean   want-reply?)

syndicate-ssh/ssh-numbers.rkt

@@ -1,22 +1,6 @@
 #lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
 
 (require "mapping.rkt")
 
@@ -88,6 +72,7 @@
 (define SSH_MSG_USERAUTH_FAILURE                51)    ;[SSH-USERAUTH]
 (define SSH_MSG_USERAUTH_SUCCESS                52)    ;[SSH-USERAUTH]
 (define SSH_MSG_USERAUTH_BANNER                 53)    ;[SSH-USERAUTH]
+(define SSH_MSG_USERAUTH_PK_OK                  60)    ;RFC 4252 section 7
 (define SSH_MSG_GLOBAL_REQUEST                  80)    ;[SSH-CONNECT]
 (define SSH_MSG_REQUEST_SUCCESS                 81)    ;[SSH-CONNECT]
 (define SSH_MSG_REQUEST_FAILURE                 82)    ;[SSH-CONNECT]
@@ -318,6 +303,7 @@
 ;;       ------------                         ---------
          diffie-hellman-group1-sha1    ;[SSH-TRANS, Section 8.1]
          diffie-hellman-group14-sha1   ;[SSH-TRANS, Section 8.2]
+         diffie-hellman-group14-sha256 ;; RFC8268 section 5
 	 ))
 
 ;; The following table identifies the initial assignment of the
@@ -373,6 +359,10 @@
          hmac-md5                         ;[SSH-TRANS, Section 6.4]
          hmac-md5-96                      ;[SSH-TRANS, Section 6.4]
          none                             ;[SSH-TRANS, Section 6.4]
+
+         hmac-sha2-256 ;; RFC6668 Section 2
+         hmac-sha2-512 ;; RFC6668 Section 2
+
 	 ))
 
 ;; The following table identifies the initial assignments of the Public
@@ -384,6 +374,9 @@
          ssh-rsa                           ;[SSH-TRANS, Section 6.6]
          pgp-sign-rsa                      ;[SSH-TRANS, Section 6.6]
          pgp-sign-dss                      ;[SSH-TRANS, Section 6.6]
+
+         ssh-ed25519 ;; RFC8709 section 3
+         ssh-ed448   ;; RFC8709 section 3
 	 ))
 
 ;; The following table identifies the initial assignments of the

syndicate-ssh/ssh-session.rkt

@@ -0,0 +1,790 @@
+#lang syndicate
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(require bitsyntax)
+(require syndicate/drivers/timer)
+(require syndicate/drivers/stream)
+(require syndicate/pattern)
+
+(require "crypto.rkt")
+(require "oakley-groups.rkt")
+(require "ssh-keys.rkt")
+(require "ssh-numbers.rkt")
+(require "ssh-message-types.rkt")
+(require "ssh-exceptions.rkt")
+(require "ssh-transport.rkt")
+(require "ssh-channel.rkt")
+(require "schemas/channel.rkt")
+(require "schemas/auth.rkt")
+
+(provide 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 (SshAuthenticatedUser String Bytes), 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.
+
+;; 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 rekey-interval (make-parameter 3600))
+(define rekey-volume (make-parameter 1000000000))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Packet dispatch and handling
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (task Nat Byte Bytes SshMsg)
+;; (task-complete Nat)
+;; Message handlers respond to `task` messages, eventually sending `task-complete`.
+(struct task (seq packet-type packet message) #:prefab)
+(struct task-complete (seq) #:prefab)
+
+(define-syntax with-incoming-task
+  (syntax-rules ()
+    [(_ #:done done! (type-byte packet-pattern message-pattern) body ...)
+     (with-incoming-task* on done! (type-byte packet-pattern message-pattern)
+       body ...)]
+    [(_ (type-byte packet-pattern message-pattern) body ...)
+     (with-incoming-task #:done done! (type-byte packet-pattern message-pattern)
+       body ...
+       (done!))]))
+
+(define-syntax-rule
+  (with-incoming-task/react (type-byte packet-pattern message-pattern) body ...)
+  (react
+    (with-incoming-task* stop-on done! (type-byte packet-pattern message-pattern)
+      body ...
+      (done!))))
+
+(define-syntax with-incoming-task*
+  (syntax-rules ()
+    [(_ on-stx k-id (type-byte packet-pattern message-pattern) body ...)
+     (on-stx (message (task ($ seq-id _) type-byte packet-pattern message-pattern))
+             (let ((k-id (lambda () (send! (task-complete seq-id)))))
+               body ...))]))
+
+(define-syntax-rule (with-assertion-presence assertion
+                      #:on-present [body-present ...]
+                      #:on-absent [body-absent ...])
+  (let/query ([present? (query-value #f assertion #t)])
+    (if present?
+        (let () body-present ... (void))
+        (let () body-absent ... (void)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Key Exchange
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (rekey-in-seconds-or-bytes delta-seconds delta-bytes total-transferred)
+  (rekey-wait (+ (current-seconds) delta-seconds)
+	      (+ total-transferred delta-bytes)))
+
+;; DS (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 conn-ds 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
+                            conn-ds
+                            `((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))))))
+
+;; HashFunction ExchangeHashInfo Bytes Natural Natural Natural -> Bytes
+;; Computes the session ID as defined by SSH's DH key exchange method.
+(define (dh-exchange-hash hash-alg hash-info host-key e f k)
+  (let ((block-to-hash
+	 (bit-string->bytes
+	  (bit-string ((exchange-hash-info-client-id hash-info) :: (t:string))
+		      ((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))))))
+    (hash-alg block-to-hash)))
+
+;; DS ExchangeHashInfo Symbol Symbol (Bytes Bytes Symbol -> Void) -> Void
+;; Performs the server's half of the Diffie-Hellman key exchange protocol.
+(define (perform-server-key-exchange conn-ds hash-info kex-alg host-key-private host-key-alg finish)
+  (match kex-alg
+    ['diffie-hellman-group14-sha256
+     (define group dh:oakley-group-14)
+     (define private-key (generate-private-key group))
+     (match-define (list 'dh 'public p g public-key-as-integer)
+       (pk-key->datum private-key 'rkt-public))
+     (at conn-ds
+       (with-incoming-task/react (SSH_MSG_KEXDH_INIT _ (ssh-msg-kexdh-init $e))
+         (define peer-key (datum->pk-key (list 'dh 'public p g e) 'rkt-public))
+         (define shared-secret (pk-derive-secret private-key peer-key))
+         (define hash-alg sha256)
+         (define host-key-public (pk-key->public-only-key host-key-private))
+         (define host-key-bytes (pieces->ssh-key (public-key->pieces host-key-public)))
+         (define exchange-hash (dh-exchange-hash hash-alg
+                                                 hash-info
+                                                 host-key-bytes
+                                                 e
+                                                 public-key-as-integer
+                                                 (bit-string->integer shared-secret #t #f)))
+         (define h-signature (make-key-signature host-key-private host-key-alg exchange-hash))
+         (send! (outbound-packet
+                 (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
+                                      public-key-as-integer
+                                      (bit-string->bytes h-signature))))
+         (finish shared-secret exchange-hash hash-alg)))]
+    [_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED
+                              "Bad key-exchange algorithm ~v" kex-alg)]))
+
+;; DS ExchangeHashInfo Symbol Symbol (Bytes Bytes Symbol -> Void) -> Void
+;; Performs the client's half of the Diffie-Hellman key exchange protocol.
+(define (perform-client-key-exchange conn-ds hash-info kex-alg host-key-public host-key-alg finish)
+  (match kex-alg
+    ['diffie-hellman-group14-sha256
+     (define group dh:oakley-group-14)
+     (define private-key (generate-private-key group))
+     (match-define (list 'dh 'public p g public-key-as-integer)
+       (pk-key->datum private-key 'rkt-public))
+     (at conn-ds
+       (send! (outbound-packet (ssh-msg-kexdh-init public-key-as-integer)))
+       (with-incoming-task/react
+         (SSH_MSG_KEXDH_REPLY _ (ssh-msg-kexdh-reply $host-key-bytes $f $h-signature))
+         (define peer-key (datum->pk-key (list 'dh 'public p g f) 'rkt-public))
+         (define shared-secret (pk-derive-secret private-key peer-key))
+         (define hash-alg sha256)
+         (when (not (equal? (ssh-key->pieces host-key-bytes) (public-key->pieces host-key-public)))
+           (disconnect-with-error conn-ds SSH_DISCONNECT_HOST_KEY_NOT_VERIFIABLE
+                                  "Unexpected host key! ~v" host-key-bytes))
+         (define exchange-hash (dh-exchange-hash hash-alg
+                                                 hash-info
+                                                 host-key-bytes
+                                                 public-key-as-integer
+                                                 f
+                                                 (bit-string->integer shared-secret #t #f)))
+         (verify-key-signature! host-key-public host-key-alg exchange-hash h-signature)
+         (finish shared-secret exchange-hash hash-alg)))]
+    [_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED
+                              "Bad key-exchange algorithm ~v" kex-alg)]))
+
+(define (do-kexinit conn-ds
+                    ground-ds
+                    #:packet packet
+                    #:message message
+                    #:rekey-state rekey-state
+                    #:is-server? is-server?
+                    #:supplied-host-key supplied-host-key
+                    #:local-id local-id
+                    #:remote-id remote-id
+                    #:session-id session-id
+                    #:total-transferred total-transferred
+                    #:discard-next-packet? discard-next-packet?)
+  (define local-algs
+    (match (rekey-state)
+      [(? rekey-wait?) ((local-algorithm-list))]
+      [(rekey-local local-algs) local-algs]
+      [(? rekey-in-progress?)
+       (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR
+                              "Received SSH_MSG_KEXINIT during ongoing key exchange")]))
+  (define encoded-local-algs (ssh-message-encode local-algs))
+  (define remote-algs message)
+  (define encoded-remote-algs packet)
+
+  (define c (if is-server? remote-algs local-algs))
+  (define s (if is-server? local-algs remote-algs))
+
+  (define kex-alg (best-result conn-ds ssh-msg-kexinit-kex_algorithms c s))
+  (define host-key-alg (best-result conn-ds ssh-msg-kexinit-server_host_key_algorithms c s))
+  (define c2s-enc (best-result conn-ds ssh-msg-kexinit-encryption_algorithms_client_to_server c s))
+  (define s2c-enc (best-result conn-ds ssh-msg-kexinit-encryption_algorithms_server_to_client c s))
+  (define c2s-mac (best-result conn-ds ssh-msg-kexinit-mac_algorithms_client_to_server c s))
+  (define s2c-mac (best-result conn-ds ssh-msg-kexinit-mac_algorithms_server_to_client c s))
+  (define c2s-zip (best-result conn-ds ssh-msg-kexinit-compression_algorithms_client_to_server c s))
+  (define s2c-zip (best-result conn-ds 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)))))
+
+  (when should-discard-first-kex-packet
+    (discard-next-packet? #t))
+
+  (when (rekey-wait? (rekey-state))
+    (rekey-state (rekey-local local-algs))
+    (send! conn-ds (outbound-packet local-algs)))
+
+  ((if is-server? perform-server-key-exchange perform-client-key-exchange)
+   conn-ds
+   (if is-server?
+       (exchange-hash-info remote-id local-id encoded-remote-algs encoded-local-algs)
+       (exchange-hash-info local-id remote-id encoded-local-algs encoded-remote-algs))
+   kex-alg
+   supplied-host-key
+   (string->bytes/utf-8 (symbol->string host-key-alg))
+   (lambda (shared-secret exchange-hash hash-alg)
+     (when (not (session-id)) (session-id exchange-hash)) ;; don't overwrite existing ID
+     (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))))))))))
+     (at conn-ds
+       (with-incoming-task/react (SSH_MSG_NEWKEYS _ (ssh-msg-newkeys))
+         ;; First, send our SSH_MSG_NEWKEYS, incrementing the
+         ;; various counters, and then apply the new algorithms.
+         ;; Also arm our rekey timer.
+         (rekey-state (rekey-in-seconds-or-bytes (rekey-interval)
+                                                 (rekey-volume)
+                                                 (total-transferred)))
+         (send! 'enable-service-request-handler)
+         (send! (outbound-packet (ssh-msg-newkeys)))
+         (send! (new-keys is-server?
+                          (embedded derive-key)
+                          c2s-enc s2c-enc
+                          c2s-mac s2c-mac
+                          c2s-zip s2c-zip))
+         (send! ground-ds (SetTimer 'rekey-timer
+                                    (* (rekey-wait-deadline (rekey-state)) 1000)
+                                    (TimerKind-absolute))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Service request manager and user authentication
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (service-request-handler conn-ds session-id)
+  (define-field authentication-state #f)
+  (begin/dataflow (log-info "authentication-state ~s" (authentication-state)))
+
+  (define (run-userauth)
+    (define expected-service #"ssh-connection")
+    (at conn-ds
+      (send! (outbound-packet (ssh-msg-userauth-banner "Welcome to Racket SSH!\r\n" #"")))
+      (react
+        (define/query-set remaining-methods (SshAuthenticationMethodAcceptable $m)
+          (parse-SshAuthMethod m))
+
+        (define (give-up-on method)
+          (log-info "Giving up on ~v" method)
+          (remaining-methods (set-remove (remaining-methods) method))
+          (auth-fail))
+
+        (define (with-method-check method done! proc)
+          (if (set-member? (remaining-methods) method)
+              (proc)
+              (begin (auth-fail)
+                     (done!))))
+
+        (define (auth-fail)
+          (define remaining (map (lambda (m) (string->symbol (bytes->string/utf-8 (->preserve m))))
+                                 (set->list (remaining-methods))))
+          (send! (outbound-packet
+                  (ssh-msg-userauth-failure (if (null? remaining) '(none) remaining) #f))))
+
+        (define (auth-ok user-name)
+          (stop-current-facet
+           (send! (outbound-packet (ssh-msg-userauth-success)))
+           (authentication-state (SshAuthenticatedUser user-name expected-service))
+           ;; RFC4252 section 5.1 page 6:
+           (react (with-incoming-task (SSH_MSG_USERAUTH_REQUEST _ _)))
+           (spawn #:name 'channel-manager (run-channel-manager conn-ds))))
+
+        (with-incoming-task
+          #:done done!
+          (SSH_MSG_USERAUTH_REQUEST
+           _ (ssh-msg-userauth-request $user-name expected-service (SshAuthMethod-none) _))
+          (with-method-check (SshAuthMethod-none) done!
+            (lambda ()
+              (on (asserted (SshAuthenticationAcceptable (SshAuthMethod-none)
+                                                         (SshAuthRequest-none user-name)
+                                                         $ok))
+                (if ok
+                    (auth-ok user-name)
+                    (give-up-on (SshAuthMethod-none)))
+                (done!)))))
+
+        (with-incoming-task
+          #:done done!
+          (SSH_MSG_USERAUTH_REQUEST
+           _ (ssh-msg-userauth-request $user-name expected-service (SshAuthMethod-password) $extension))
+          (with-method-check (SshAuthMethod-password) done!
+            (lambda ()
+              (bit-string-case extension
+                ([ (= #f :: (t:boolean)) (password :: (t:string/utf-8)) ]
+                 (on (asserted (SshAuthenticationAcceptable (SshAuthMethod-password)
+                                                            (SshAuthRequest-password user-name password)
+                                                            $ok))
+                   (if ok
+                       (auth-ok user-name)
+                       (give-up-on (SshAuthMethod-password)))
+                   (done!)))
+                (else
+                 (give-up-on (SshAuthMethod-password))
+                 (done!))))))
+
+        (with-incoming-task
+          #:done done!
+          (SSH_MSG_USERAUTH_REQUEST
+           _ (ssh-msg-userauth-request $user-name expected-service (SshAuthMethod-publickey) $extension))
+          (with-method-check (SshAuthMethod-publickey) done!
+            (lambda ()
+              (define (acceptable-pk key-alg pk-bytes ks)
+                (let ((pk (ssh-key->pieces key-alg pk-bytes)))
+                  (if (not pk)
+                      (begin (auth-fail)
+                             (done!))
+                      (on (asserted (SshAuthenticationAcceptable (SshAuthMethod-publickey)
+                                                                 (SshAuthRequest-publickey user-name pk)
+                                                                 $ok))
+                        (if ok (ks pk) (auth-fail))
+                        (done!)))))
+
+              (bit-string-case extension
+                ([ (= #f :: (t:boolean))
+                   (key-alg :: (t:string #:pack))
+                   (pk-blob :: (t:string #:pack)) ]
+                 (acceptable-pk
+                  key-alg pk-blob
+                  (lambda (pk) (send! (outbound-packet (ssh-msg-userauth-pk-ok key-alg pk-blob))))))
+                ([ (= #t :: (t:boolean))
+                   (key-alg :: (t:string #:pack))
+                   (pk-bytes :: (t:string #:pack))
+                   (signature :: (t:string #:pack)) ]
+                 (acceptable-pk
+                  key-alg pk-bytes
+                  (lambda (pk)
+                    (let* ((exchange-hash
+                            (bit-string->bytes
+                             (bit-string ((session-id) :: (t:string))
+                                         SSH_MSG_USERAUTH_REQUEST
+                                         (user-name :: (t:string/utf-8))
+                                         (expected-service :: (t:string))
+                                         ((->preserve (SshAuthMethod-publickey)) :: (t:string))
+                                         (#t :: (t:boolean))
+                                         (key-alg :: (t:string))
+                                         (pk-bytes :: (t:string))))))
+                      (verify-key-signature! (pieces->public-key pk)
+                                             key-alg
+                                             exchange-hash
+                                             signature)
+                      (auth-ok user-name)))))
+                (else
+                 (give-up-on (SshAuthMethod-publickey))
+                 (done!)))))))))
+
+  (at conn-ds
+    (assert #:when (authentication-state) (authentication-state))
+
+    (with-incoming-task (SSH_MSG_SERVICE_REQUEST _ (ssh-msg-service-request $service))
+      (match service
+        [#"ssh-userauth"
+         (if (authentication-state)
+             (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
+                                    "Repeated authentication is not permitted")
+             (begin (send! (outbound-packet (ssh-msg-service-accept service)))
+                    (run-userauth)))]
+        [_
+         (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
+                                "Service ~v not supported"
+                                service)]))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Channel management
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (run-inbound-channel conn-ds
+                             #:type channel-type
+                             #:remote-ref remote-ref
+                             #:local-ref local-ref
+                             #:initial-window-size initial-window-size
+                             #:maximum-packet-size maximum-packet-size
+                             #:extra-request-data extra-request-data)
+  (define (! message) (send! conn-ds (outbound-packet message)))
+
+  (log-info "Starting channel, type ~s" channel-type)
+  (on-stop (log-info "Stopping channel, type ~s" channel-type))
+
+  (define (on-connect source sink)
+    (at conn-ds
+      (stop-on (message (task _ SSH_MSG_CHANNEL_CLOSE _ (ssh-msg-channel-close local-ref))))
+
+      (with-incoming-task
+        (SSH_MSG_CHANNEL_WINDOW_ADJUST _ (ssh-msg-channel-window-adjust local-ref $n))
+        (send-bytes-credit source n))
+
+      (with-incoming-task (SSH_MSG_CHANNEL_DATA _ (ssh-msg-channel-data local-ref $data))
+        (send-data sink data))
+
+      (with-incoming-task
+        (SSH_MSG_CHANNEL_EXTENDED_DATA _ (ssh-msg-channel-extended-data local-ref $type-code $data))
+        (send-data sink data (Mode-object (SshChannelObject-extendedData type-code))))
+
+      (with-incoming-task (SSH_MSG_CHANNEL_EOF _ (ssh-msg-channel-eof local-ref))
+        (send-eof sink))
+
+      (with-incoming-task
+        (SSH_MSG_CHANNEL_REQUEST _ (ssh-msg-channel-request local-ref $type $want-reply? $data))
+        (send-data sink data (Mode-object (SshChannelObject-request type want-reply?))))
+
+      (with-incoming-task
+        (SSH_MSG_CHANNEL_SUCCESS _ (ssh-msg-channel-success local-ref))
+        (send-data sink #"" (Mode-object (SshChannelObject-success))))
+
+      (with-incoming-task
+        (SSH_MSG_CHANNEL_FAILURE _ (ssh-msg-channel-failure local-ref))
+        (send-data sink #"" (Mode-object (SshChannelObject-failure))))
+
+      (once
+       [(asserted (SshChannelOpenResponse-ok remote-sink $extra-data))
+        (! (ssh-msg-channel-open-confirmation remote-ref
+                                              local-ref
+                                              1048576 ;; TODO
+                                              16384 ;; TODO
+                                              extra-data))]
+       [(asserted (SshChannelOpenResponse-fail remote-sink $reason $description))
+        (! (ssh-msg-channel-open-failure remote-ref
+                                         reason
+                                         description
+                                         #""))
+        (stop-current-facet)])))
+
+  (match-define
+    (list remote-source remote-sink)
+    (establish-connection conn-ds (SshChannelLocal channel-type extra-request-data)
+                          #:name (list 'R remote-ref 'L local-ref)
+                          #:on-connect on-connect
+                          #:on-rejected
+                          (lambda (message)
+                            (! (ssh-msg-channel-open-failure remote-ref
+                                                             SSH_OPEN_ADMINISTRATIVELY_PROHIBITED
+                                                             (string->bytes/utf-8 message)
+                                                             #""))
+                            (stop-current-facet))
+                          #:on-disconnect (lambda () (stop-current-facet))
+                          #:on-error (lambda (message) (stop-current-facet))
+                          #:on-credit
+                          (lambda (amount mode)
+                            (match-define (Mode-bytes) mode)
+                            (match-define (CreditAmount-count n) amount)
+                            (! (ssh-msg-channel-window-adjust remote-ref n)))
+                          #:initial-credit (CreditAmount-count initial-window-size)
+                          #:initial-mode (Mode-bytes)
+                          #:on-data
+                          (lambda (data mode)
+                            (match mode
+                              [(Mode-bytes)
+                               (! (ssh-msg-channel-data remote-ref data))]
+                              [(Mode-lines (LineMode-lf))
+                               (! (ssh-msg-channel-data remote-ref (bytes-append data "\n")))]
+                              [(Mode-lines (LineMode-crlf))
+                               (! (ssh-msg-channel-data remote-ref (bytes-append data "\r\n")))]
+                              [(Mode-object (:parse (SshChannelObject-extendedData type-code)))
+                               (! (ssh-msg-channel-extended-data remote-ref type-code data))]
+                              [(Mode-object (:parse (SshChannelObject-request type want-reply)))
+                               (! (ssh-msg-channel-request remote-ref type want-reply data))]
+                              [(Mode-object (:parse (SshChannelObject-success)))
+                               (! (ssh-msg-channel-success remote-ref))]
+                              [(Mode-object (:parse (SshChannelObject-failure)))
+                               (! (ssh-msg-channel-failure remote-ref))]))
+                          #:on-eof (lambda ()
+                                     (! (ssh-msg-channel-eof remote-ref)))))
+  (void))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Channel manager
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (run-channel-manager conn-ds)
+  (define local-refs-by-remote-ref (make-hash))
+  (define remote-refs-by-local-ref (make-hash))
+
+  (define (allocate-local-ref remote-ref)
+    (when (hash-has-key? local-refs-by-remote-ref remote-ref)
+      (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR
+                             "Attempt to reuse remote-ref ~a"
+                             remote-ref))
+    (for/or ([i (in-range 0 32)]) ;; TODO: this is an arbitrary limit
+      (if (hash-has-key? remote-refs-by-local-ref i)
+          #f
+          (begin (hash-set! remote-refs-by-local-ref i remote-ref)
+                 (hash-set! local-refs-by-remote-ref remote-ref i)
+                 i))))
+
+  (at conn-ds
+
+    (with-incoming-task (SSH_MSG_CHANNEL_CLOSE _ (ssh-msg-channel-close $local-ref))
+      (when (not (hash-has-key? remote-refs-by-local-ref local-ref))
+        (disconnect-with-error conn-ds
+                               SSH_DISCONNECT_PROTOCOL_ERROR
+                               "Received channel close for non-open channel ~a"
+                               local-ref))
+      (hash-remove! remote-refs-by-local-ref local-ref))
+
+    (with-incoming-task (SSH_MSG_CHANNEL_OPEN _ (ssh-msg-channel-open $channel-type
+                                                                      $remote-ref
+                                                                      $initial-window-size
+                                                                      $maximum-packet-size
+                                                                      $extra-request-data))
+      (log-info "open ~s" (list channel-type remote-ref initial-window-size maximum-packet-size extra-request-data))
+      (with-assertion-presence (SshChannelTypeAvailable channel-type)
+        #:on-present [(define local-ref (allocate-local-ref remote-ref))
+                      (if (not local-ref)
+                          (send! (outbound-packet
+                                  (ssh-msg-channel-open-failure remote-ref
+                                                                SSH_OPEN_RESOURCE_SHORTAGE
+                                                                #"Too many open channels"
+                                                                #"")))
+                          (react
+                            (on-stop (log-info "Releasing channel assignment ~s"
+                                               (list 'R remote-ref 'L local-ref))
+                                     (send! (outbound-packet (ssh-msg-channel-close remote-ref)))
+                                     (hash-remove! local-refs-by-remote-ref remote-ref))
+                            (spawn/link
+                             #:name (list 'R remote-ref 'L local-ref)
+                             (run-inbound-channel conn-ds
+                                                  #:type channel-type
+                                                  #:remote-ref remote-ref
+                                                  #:local-ref local-ref
+                                                  #:initial-window-size initial-window-size
+                                                  #:maximum-packet-size maximum-packet-size
+                                                  #:extra-request-data extra-request-data))))]
+        #:on-absent [(send! (outbound-packet
+                             (ssh-msg-channel-open-failure remote-ref
+                                                           SSH_OPEN_UNKNOWN_CHANNEL_TYPE
+                                                           #"Unknown channel type"
+                                                           #"")))])))
+
+  ;; Start responding to channel interest coming from the application. We are responding to
+  ;; channels appearing from the remote peer by virtue of our installation of the handler for
+  ;; SSH_MSG_CHANNEL_OPEN above.
+
+  ;; (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
+  ;;                      (match-state conn
+  ;;                                   (match-conversation (channel-message (channel-stream-name #t cname) _)
+  ;;                                                       (on-presence (respond-to-opened-outbound-channel conn cname)))))
+  ;; (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
+  ;;                     (match-state conn
+  ;;                                  (match-conversation (channel-message (channel-stream-name #f cname) _)
+  ;;                                                      (on-presence (respond-to-opened-outbound-channel conn cname)))))
+
+  )
+
+
+
+;; (define (handle-msg-channel-open-confirmation packet message conn)
+;;   (match-define (ssh-msg-channel-open-confirmation local-ref
+;; 						   remote-ref
+;; 						   initial-window-size
+;; 						   maximum-packet-size
+;; 						   extra-request-data*)
+;;     message)
+;;   (define ch (get-channel conn local-ref))
+;;   (define extra-request-data (bit-string->bytes extra-request-data*))
+;;   (define outbound-stream (channel-stream-name #f (ssh-channel-name ch)))
+;;   (transition (update-channel (ssh-channel-name ch)
+;; 			      (lambda (c)
+;; 				(struct-copy ssh-channel c
+;; 					     [remote-ref remote-ref]
+;; 					     [outbound-packet-size maximum-packet-size]))
+;; 			      conn)
+;;     (send-feedback (channel-message outbound-stream
+;; 				    (channel-stream-config maximum-packet-size
+;; 							   extra-request-data)))
+;;     (send-feedback (channel-message outbound-stream
+;; 				    (channel-stream-credit initial-window-size)))))
+
+;; (define (handle-msg-channel-open-failure packet message conn)
+;;   (match-define (ssh-msg-channel-open-failure local-ref
+;; 					      reason
+;; 					      description*
+;; 					      _)
+;;     message)
+;;   (define ch (get-channel conn local-ref))
+;;   (define description (bit-string->bytes description*))
+;;   (define inbound-stream (channel-stream-name #t (ssh-channel-name ch)))
+;;   (sequence-actions (transition conn)
+;;     (send-message (channel-message inbound-stream
+;; 				   (channel-stream-open-failure reason description)))
+;;     (lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Session main process
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (ssh-session conn-ds
+                     ground-ds
+                     local-identification-string
+		     peer-identification-string
+		     session-role
+                     supplied-host-key)
+  (define-field rekey-state (rekey-in-seconds-or-bytes -1 -1 0))
+  (define-field session-id #f)
+  (define-field total-transferred 0)
+  (define-field discard-next-packet? #f)
+
+  (define channels '())
+
+  (at conn-ds
+    (with-incoming-task
+      (SSH_MSG_DISCONNECT _ (ssh-msg-disconnect $reason-code $description $language-tag))
+      (if (= reason-code SSH_DISCONNECT_BY_APPLICATION)
+          (begin (log-debug "Received SSH_DISCONNECT_BY_APPLICATION")
+                 (assert (protocol-error reason-code description '() #t)))
+          (disconnect-with-error* conn-ds #t
+                                  '()
+                                  reason-code
+                                  "Received SSH_MSG_DISCONNECT with reason code ~a and message ~s"
+                                  reason-code
+                                  (bytes->string/utf-8 (bit-string->bytes description)))))
+
+    (with-incoming-task (SSH_MSG_IGNORE _ (ssh-msg-ignore _)))
+
+    (with-incoming-task (SSH_MSG_UNIMPLEMENTED _ (ssh-msg-unimplemented $peer-seq))
+      (disconnect-with-error/local-info
+       conn-ds
+       `((offending-sequence-number ,peer-seq))
+       SSH_DISCONNECT_PROTOCOL_ERROR
+       "Disconnecting because of received SSH_MSG_UNIMPLEMENTED."))
+
+    (with-incoming-task (SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _)))
+      (log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message)))
+
+    (with-incoming-task
+      (SSH_MSG_KEXINIT $packet ($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _)))
+      (do-kexinit conn-ds
+                  ground-ds
+                  #:packet packet
+                  #:message message
+                  #:rekey-state rekey-state
+                  #:is-server? (case session-role ((client) #f) ((server) #t))
+                  #:supplied-host-key supplied-host-key
+                  #:local-id local-identification-string
+                  #:remote-id peer-identification-string
+                  #:session-id session-id
+                  #:total-transferred total-transferred
+                  #:discard-next-packet? discard-next-packet?)))
+
+  (react
+    (at conn-ds
+      (stop-on (message 'enable-service-request-handler)
+        (spawn #:name 'service-request-handler
+               (service-request-handler conn-ds session-id)))))
+
+  (define (maybe-rekey)
+    (match (rekey-state)
+      [(rekey-wait deadline threshold-bytes)
+       (when (or (>= (current-seconds) deadline)
+                 (>= (total-transferred) threshold-bytes))
+         (define algs ((local-algorithm-list)))
+         (send! conn-ds (outbound-packet algs))
+         (rekey-state (rekey-local algs)))]
+      [_ (void)]))
+
+  (at ground-ds
+    (on (message (TimerExpired 'rekey-timer _))
+      (maybe-rekey)))
+
+  (at conn-ds
+    (on (message (outbound-byte-credit $amount))
+      (total-transferred (+ (total-transferred) amount))
+      (maybe-rekey))
+
+    (on (message (inbound-packet $sequence-number $payload $message $transfer-size))
+      (if (discard-next-packet?)
+          (begin (discard-next-packet? #f)
+                 (send! (inbound-credit 1)))
+          (let ((packet-type-number (bytes-ref payload 0)))
+            (if (and (not (rekey-wait? (rekey-state)))
+                     (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 conn-ds 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. Dispatch it.
+                (react
+                  (on-start (send! (task sequence-number packet-type-number payload message)))
+                  (with-assertion-presence (Observe (:pattern (task ,_ packet-type-number ,_ ,_)) _)
+                    #:on-present []
+                    #:on-absent [(send! (outbound-packet (ssh-msg-unimplemented sequence-number)))
+                                 (send! (task-complete sequence-number))])
+                  (stop-on (message (task-complete sequence-number)))
+                  (on-stop (send! (inbound-credit 1)))))))
+      (total-transferred (+ (total-transferred) transfer-size))
+      (maybe-rekey))))

syndicate-ssh/ssh-transport.rkt

@@ -0,0 +1,400 @@
+#lang syndicate
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(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
+	 local-algorithm-list
+
+	 ssh-reader
+	 ssh-writer)
+
+(require bitsyntax)
+(require syndicate/drivers/timer)
+(require syndicate/drivers/tcp)
+
+(require "crypto.rkt")
+(require "ssh-numbers.rkt")
+(require "ssh-message-types.rkt")
+(require "ssh-exceptions.rkt")
+
+(module+ test (require rackunit))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data definitions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; A DecodedPacket is one of the packet structures defined in
+;; ssh-message-types.rkt.
+
+;; 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)
+	#:prefab)
+
+(struct crypto-configuration (cipher
+			      cipher-description
+			      hmac
+			      hmac-description)
+	#:transparent)
+
+;; Description of a supported cipher.
+(struct supported-cipher (name factory key-length block-size iv-length)
+	#:transparent)
+
+;; Description of a supported hmac algorithm.
+(struct supported-hmac (name factory digest-length key-length)
+	#:transparent)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parameters
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define default-packet-limit (make-parameter 65536))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Encryption, MAC, and Compression algorithm descriptions and parameters
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; "none" cipher description.
+(define null-cipher-description
+  (supported-cipher 'none
+		    (lambda (enc? key iv)
+		      (lambda (block)
+			block))
+		    0
+		    8 ;; pseudo-block-size for packet I/O
+		    0))
+
+;; "none" HMAC function.
+(define (null-hmac blob)
+  #"")
+
+;; "none" HMAC description.
+(define null-hmac-description
+  (supported-hmac 'none
+		  (lambda (key)
+		    (error 'null-hmac-description
+			   "Cannot construct null hmac instance"))
+		  0
+		  0))
+
+(define (make-cipher-entry name cipher-spec key-length
+                           #:block-size [block-size (cipher-block-size cipher-spec)])
+  (list name
+	(supported-cipher name
+			  (lambda (enc? key iv)
+                            (let ((ctx ((if enc? make-encrypt-ctx make-decrypt-ctx)
+                                        cipher-spec key iv #:pad #f)))
+                              (lambda (input)
+                                (cipher-update ctx input))))
+                          key-length
+                          block-size
+			  (cipher-iv-size cipher-spec))))
+
+(define supported-crypto-algorithms
+  (list
+   (make-cipher-entry 'aes128-ctr '(aes ctr) 16 #:block-size 16)
+   (make-cipher-entry 'aes192-ctr '(aes ctr) 24 #:block-size 16)
+   (make-cipher-entry 'aes256-ctr '(aes ctr) 32 #:block-size 16)
+   (make-cipher-entry 'aes128-cbc '(aes cbc) 16)
+   (make-cipher-entry 'aes192-cbc '(aes cbc) 24)
+   (make-cipher-entry 'aes256-cbc '(aes cbc) 32)
+   (make-cipher-entry '3des-cbc '(des-ede3 cbc) 24)
+   )) ;; TODO: actually test these!
+
+(define (make-hmac-entry name digest-spec key-length-or-false)
+  (let* ((digest-length (digest-size digest-spec))
+	 (key-length (or key-length-or-false digest-length)))
+    (list name
+	  (supported-hmac name
+			  (lambda (key)
+			    (lambda (blob)
+			      (hmac digest-spec key blob)))
+			  digest-length
+			  key-length))))
+
+(define supported-hmac-algorithms
+  (list (make-hmac-entry 'hmac-sha1 'sha1 #f)))
+
+(define supported-compression-algorithms '(none)) ;; TODO: zlib, and zlib delayed
+
+(define local-algorithm-list
+  (let ((crypto-names (map car supported-crypto-algorithms))
+	(mac-names (map car supported-hmac-algorithms)))
+    (make-parameter
+     (lambda ()
+       (ssh-msg-kexinit (crypto-random-bytes 16)
+			'(diffie-hellman-group14-sha256)
+                        '(ssh-ed25519)
+			crypto-names
+			crypto-names
+			mac-names
+			mac-names
+			supported-compression-algorithms
+			supported-compression-algorithms
+			'()
+			'()
+			#f
+			0)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Cryptographic stream configuration
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define initial-crypto-configuration
+  (crypto-configuration #f
+			null-cipher-description
+			null-hmac
+			null-hmac-description))
+
+(define (apply-negotiated-options conn-ds nk is-outbound?)
+  (match-define (new-keys is-server?
+			  (embedded derive-key)
+			  c2s-enc s2c-enc
+			  c2s-mac s2c-mac
+			  c2s-zip s2c-zip) nk)
+  ;; TODO: zip
+  ;; TODO: make this less ugly. Compute all the keys, select just the ones we need afterward?
+  (define c2s
+    ;; c2s true iff stream is serverward
+    (if is-server? (not is-outbound?) is-outbound?))
+  (define enc (if c2s c2s-enc s2c-enc))
+  (define mac (if c2s c2s-mac s2c-mac))
+  (define zip (if c2s c2s-zip s2c-zip))
+
+  (define cipher-description
+    (cond
+     ((assq enc supported-crypto-algorithms) => cadr)
+     (else (disconnect-with-error conn-ds
+                                  SSH_DISCONNECT_KEY_EXCHANGE_FAILED
+				  "Could not find driver for encryption algorithm ~v"
+				  enc))))
+  (define cipher
+    ((supported-cipher-factory cipher-description)
+     is-outbound?
+     (derive-key (if c2s #"C" #"D") (supported-cipher-key-length cipher-description))
+     (derive-key (if c2s #"A" #"B") (supported-cipher-iv-length cipher-description))))
+
+  (define hmac-description
+    (cond
+     ((assq mac supported-hmac-algorithms) => cadr)
+     (else (disconnect-with-error conn-ds
+                                  SSH_DISCONNECT_KEY_EXCHANGE_FAILED
+				  "Could not find driver for HMAC algorithm ~v"
+				  mac))))
+  (define hmac
+    ((supported-hmac-factory hmac-description)
+     (derive-key (if c2s #"E" #"F") (supported-hmac-key-length hmac-description))))
+
+  (crypto-configuration cipher cipher-description
+			hmac hmac-description))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Transport utilities
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; MacFunction Natural Bytes -> Bytes
+;; Computes the HMAC trailer for a given blob at the given sequence number.
+(define (apply-hmac mac sequence-number packet)
+  (mac (bit-string->bytes (bit-string-append (integer->bit-string sequence-number 32 #t)
+					     packet))))
+
+(define (check-packet-length! conn-ds actual-length limit block-size)
+  (when (> actual-length limit)
+    (log-warning (format "Packet of length ~v exceeded our limit of ~v"
+			 actual-length
+			 limit)))
+  (when (> actual-length (* 2 limit))
+    ;; TODO: For some reason, OpenSSH seems to occasionally slightly
+    ;; exceed the packet size limit! (For example, sending a packet of
+    ;; length 65564 when I'm expecting a max of 65536.) So we actually
+    ;; enforce twice our actual limit.
+    (disconnect-with-error conn-ds
+                           0 ;; TODO: better reason code?
+			   "Packet of length ~v is longer than packet limit ~v"
+			   actual-length
+			   limit))
+  (when (not (zero? (modulo (+ actual-length 4) block-size)))
+    ;; the +4 is because the length sent on the wire doesn't include
+    ;; the length-of-length, but the requirements for transmitted
+    ;; chunks of data are that they be block-size multiples
+    ;; *including* the length-of-length
+    (disconnect-with-error conn-ds
+                           SSH_DISCONNECT_PROTOCOL_ERROR
+			   "Packet of length ~v is not a multiple of block size ~v"
+			   actual-length
+			   block-size)))
+
+;; Integer PositiveInteger -> Integer
+;; Rounds "what" up to the nearest multiple of "to".
+(define (round-up what to)
+  (* to (quotient (+ what (- to 1)) to)))
+
+(module+ test
+  (check-equal? (round-up 0 8) 0)
+  (check-equal? (round-up 1 8) 8)
+  (check-equal? (round-up 7 8) 8)
+  (check-equal? (round-up 8 8) 8)
+  (check-equal? (round-up 9 8) 16))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Encrypted Packet Input
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (ssh-reader conn-ds ground-ds source)
+  (define input-handler #f)
+  (define (update-input-handler #:on-data proc) (set! input-handler proc))
+  (make-sink #:initial-source source
+             #:name 'ssh-in
+             #:on-data (lambda (data mode) (input-handler data mode)))
+
+  (on-start (send-lines-credit source 1 (LineMode-crlf)))
+  (update-input-handler
+   #:on-data (lambda (remote-identification _mode)
+               (send! conn-ds (ssh-identification-line remote-identification))
+               (stop-facet identification-line-timeout-facet)
+               (update-input-handler #:on-data handle-packet-header)))
+  (define identification-line-timeout-facet
+    (at ground-ds
+      (once [(timeout 10000)
+             (log-info "Timeout waiting for remote-identification")
+             (stop-current-facet)])))
+
+  (define packet-size-limit (default-packet-limit))
+  (define sequence-number 0)
+  (define remaining-credit 0)
+
+  (define config initial-crypto-configuration)
+
+  (define (current-cipher) (crypto-configuration-cipher config))
+  (define (block-size)
+    (supported-cipher-block-size (crypto-configuration-cipher-description config)))
+  (define (decrypt-chunk chunk) ((or (current-cipher) values) chunk))
+  (define (subsequent-block-size) (if (current-cipher) (block-size) 1))
+  (define (hmac) (crypto-configuration-hmac config))
+
+  (define (issue-credit)
+    (when (positive? remaining-credit)
+      (send-packet-credit source (block-size))))
+
+  (define (handle-packet-header encrypted-packet _mode)
+    (define first-block (decrypt-chunk encrypted-packet))
+    (define packet-length (integer-bytes->integer first-block #f #t 0 4))
+    (check-packet-length! conn-ds packet-length packet-size-limit (subsequent-block-size))
+    (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)
+        (begin
+          (send-packet-credit source remaining-to-read)
+          (update-input-handler
+           #:on-data (lambda (encrypted-packet _mode)
+                       (define subsequent-chunk (decrypt-chunk encrypted-packet))
+                       (check-hmac (bytes-append first-block subsequent-chunk) packet-length))))
+        (check-hmac first-block packet-length)))
+
+  (define (check-hmac packet packet-length)
+    (define payload-length (let ((padding-length (bytes-ref packet 4)))
+                             (- packet-length padding-length 1)))
+    (define computed-hmac-bytes (apply-hmac (hmac) sequence-number packet))
+    (define mac-byte-count (bytes-length computed-hmac-bytes))
+    (if (positive? mac-byte-count)
+        (begin
+          (send-packet-credit source mac-byte-count)
+          (update-input-handler
+           #:on-data (lambda (received-hmac-bytes _mode)
+                       (if (equal? computed-hmac-bytes received-hmac-bytes)
+                           (finish-packet mac-byte-count packet-length payload-length packet)
+                           (disconnect-with-error/local-info conn-ds
+                                                             `((expected-hmac ,computed-hmac-bytes)
+                                                               (actual-hmac ,received-hmac-bytes))
+                                                             SSH_DISCONNECT_MAC_ERROR
+                                                             "Corrupt MAC")))))
+        (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)))
+    (update-input-handler #:on-data handle-packet-header)
+    (send! conn-ds (inbound-packet sequence-number
+                                   payload
+                                   (ssh-message-decode payload)
+                                   bytes-read))
+    (set! sequence-number (+ sequence-number 1))
+    (set! remaining-credit (- remaining-credit 1))
+    (issue-credit))
+
+  (at conn-ds
+    (on (message (inbound-credit $amount))
+      (set! remaining-credit (+ remaining-credit amount))
+      (issue-credit))
+
+    (on (message ($ nk (new-keys _ _ _ _ _ _ _ _)))
+      (set! config (apply-negotiated-options conn-ds nk #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Encrypted Packet Output
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (ssh-writer conn-ds sink local-identification)
+  (define config initial-crypto-configuration)
+  (define sequence-number 0)
+
+  (on-start (send-line sink local-identification))
+  (make-source #:initial-sink sink
+               #:name 'ssh-out)
+
+  (define (block-size)
+    (supported-cipher-block-size (crypto-configuration-cipher-description config)))
+  (define (encrypt-chunk chunk) ((or (crypto-configuration-cipher config) values) chunk))
+  (define (hmac) (crypto-configuration-hmac config))
+
+  (at conn-ds
+    (on (message (outbound-packet $message))
+      (define pad-block-size (block-size))
+      (define payload (ssh-message-encode message))
+      ;; There must be at least 4 bytes of padding, and padding needs to
+      ;; make the packet length a multiple of pad-block-size.
+      (define unpadded-length (+ 4 ;; length of length
+                                 1 ;; length of length-of-padding indicator
+                                 (bit-string-byte-count payload)))
+      (define min-padded-length (+ unpadded-length 4))
+      (define padded-length (round-up min-padded-length pad-block-size))
+      (define padding-length (- padded-length unpadded-length))
+      (define packet-length (- padded-length 4))
+      ;; ^^ the packet length does *not* include itself!
+      (define packet (bit-string->bytes
+                      (bit-string (packet-length :: integer bits 32)
+                                  (padding-length :: integer bits 8)
+                                  (payload :: binary)
+                                  ((crypto-random-bytes padding-length) :: binary))))
+      (define encrypted-packet (encrypt-chunk packet))
+      (define computed-hmac-bytes (apply-hmac (hmac) sequence-number packet))
+      (define mac-byte-count (bytes-length computed-hmac-bytes))
+      (send-data sink encrypted-packet)
+      (send-data sink computed-hmac-bytes)
+      (send! (outbound-byte-credit (+ (bytes-length encrypted-packet)
+                                      (bytes-length computed-hmac-bytes))))
+      (set! sequence-number (+ sequence-number 1)))
+
+    (on (message ($ nk (new-keys _ _ _ _ _ _ _ _)))
+      (set! config (apply-negotiated-options conn-ds nk #t)))))

syndicate-ssh/test-host-keys/ssh_host_dsa_key

@@ -0,0 +1,21 @@
+-----BEGIN OPENSSH PRIVATE KEY-----
+b3BlbnNzaC1rZXktdjEAAAAABG5vbmUAAAAEbm9uZQAAAAAAAAABAAABsQAAAAdzc2gtZH
+NzAAAAgQCmKbQ9aCROeTmgoNw7/2iajqqMii8GY57HzBNMPv5qkhpK/C3FPRZ4kI8ZWoBd
+y24YGjowMe8mi2cLr3Gh92tQxXkgj2PKvS+ciuLJc9wZNkWlb8EGMSObZS37vsY+4QQ+i3
+Bzl8/NaKcRm3fNDzo4bPs4KSv20oW53MHwMTuJQwAAABUA6kkgOVsAp/6YzxsPRVq5s2HR
+80cAAACAYawX51aiHeSfbwvRO7aewJJVIZIW/56A3jvn8LQAnLXN7E15fyKf+/0curiDA5
+Y/XnnhYVx6fy6+TmTFe29J8Epbf/Du1kMQXuYPitH+bAAO6WV20cFzuDiwalmwGzakA4my
+jsNUOKfRi9SVtj9wCcROdTpEd2ZuWZIeCkpN9nwAAACAYjn7aqpWxBrkMEpkFm8mv5q3oC
+rDE1WEzOFbdjZCNHv0WCNlWuvSmgxbhOgH16NCkPQpKGeJYC/L3i+nAxqt9OcYMnNP+QOA
+U7mMtWIYk6/AWjif4xPbevuqXwjXBNtaJxTM5rx7VgRXTpGknPAnmmr3d8rx4JqiUUZ/9U
+ZKhJIAAAHg+nHUbPpx1GwAAAAHc3NoLWRzcwAAAIEApim0PWgkTnk5oKDcO/9omo6qjIov
+BmOex8wTTD7+apIaSvwtxT0WeJCPGVqAXctuGBo6MDHvJotnC69xofdrUMV5II9jyr0vnI
+riyXPcGTZFpW/BBjEjm2Ut+77GPuEEPotwc5fPzWinEZt3zQ86OGz7OCkr9tKFudzB8DE7
+iUMAAAAVAOpJIDlbAKf+mM8bD0VaubNh0fNHAAAAgGGsF+dWoh3kn28L0Tu2nsCSVSGSFv
++egN475/C0AJy1zexNeX8in/v9HLq4gwOWP1554WFcen8uvk5kxXtvSfBKW3/w7tZDEF7m
+D4rR/mwADulldtHBc7g4sGpZsBs2pAOJso7DVDin0YvUlbY/cAnETnU6RHdmblmSHgpKTf
+Z8AAAAgGI5+2qqVsQa5DBKZBZvJr+at6AqwxNVhMzhW3Y2QjR79FgjZVrr0poMW4ToB9ej
+QpD0KShniWAvy94vpwMarfTnGDJzT/kDgFO5jLViGJOvwFo4n+MT23r7ql8I1wTbWicUzO
+a8e1YEV06RpJzwJ5pq93fK8eCaolFGf/VGSoSSAAAAFQCA9HN3MB5LBCbMmgC8GaLL6Dvs
+swAAAAl0b255Z0B6aXAB
+-----END OPENSSH PRIVATE KEY-----

syndicate-ssh/test-host-keys/ssh_host_dsa_key.pub

@@ -0,0 +1 @@
+ssh-dss AAAAB3NzaC1kc3MAAACBAKYptD1oJE55OaCg3Dv/aJqOqoyKLwZjnsfME0w+/mqSGkr8LcU9FniQjxlagF3LbhgaOjAx7yaLZwuvcaH3a1DFeSCPY8q9L5yK4slz3Bk2RaVvwQYxI5tlLfu+xj7hBD6LcHOXz81opxGbd80POjhs+zgpK/bShbncwfAxO4lDAAAAFQDqSSA5WwCn/pjPGw9FWrmzYdHzRwAAAIBhrBfnVqId5J9vC9E7tp7AklUhkhb/noDeO+fwtACctc3sTXl/Ip/7/Ry6uIMDlj9eeeFhXHp/Lr5OZMV7b0nwSlt/8O7WQxBe5g+K0f5sAA7pZXbRwXO4OLBqWbAbNqQDibKOw1Q4p9GL1JW2P3AJxE51OkR3Zm5Zkh4KSk32fAAAAIBiOftqqlbEGuQwSmQWbya/mregKsMTVYTM4Vt2NkI0e/RYI2Va69KaDFuE6AfXo0KQ9CkoZ4lgL8veL6cDGq305xgyc0/5A4BTuYy1YhiTr8BaOJ/jE9t6+6pfCNcE21onFMzmvHtWBFdOkaSc8Ceaavd3yvHgmqJRRn/1RkqEkg== tonyg@zip

syndicate-ssh/test-host-keys/ssh_host_ecdsa_key

@@ -0,0 +1,9 @@
+-----BEGIN OPENSSH PRIVATE KEY-----
+b3BlbnNzaC1rZXktdjEAAAAABG5vbmUAAAAEbm9uZQAAAAAAAAABAAAAaAAAABNlY2RzYS
+1zaGEyLW5pc3RwMjU2AAAACG5pc3RwMjU2AAAAQQQQh/51Eusyw+QiETwkFKnih14O/P6X
+QzaQggoFhLVlU8CEd0rYelEC+PIDthkLLK7FxLFw5hFAFA1nZH0+HX8NAAAAqEsrs/tLK7
+P7AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBBCH/nUS6zLD5CIR
+PCQUqeKHXg78/pdDNpCCCgWEtWVTwIR3Sth6UQL48gO2GQssrsXEsXDmEUAUDWdkfT4dfw
+0AAAAgF1PQpFeePfE/wd6/FvykZPd4gYWdf6dKvae487FkMXQAAAAJdG9ueWdAemlwAQID
+BAUGBw==
+-----END OPENSSH PRIVATE KEY-----

syndicate-ssh/test-host-keys/ssh_host_ecdsa_key.pub

@@ -0,0 +1 @@
+ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBBCH/nUS6zLD5CIRPCQUqeKHXg78/pdDNpCCCgWEtWVTwIR3Sth6UQL48gO2GQssrsXEsXDmEUAUDWdkfT4dfw0= tonyg@zip

syndicate-ssh/test-host-keys/ssh_host_ed25519_key

@@ -0,0 +1,7 @@
+-----BEGIN OPENSSH PRIVATE KEY-----
+b3BlbnNzaC1rZXktdjEAAAAABG5vbmUAAAAEbm9uZQAAAAAAAAABAAAAMwAAAAtzc2gtZW
+QyNTUxOQAAACDV6tAG149uzUDypi8xFrtKueqfn4oWtsThNP2CztT92AAAAJCOjer7jo3q
++wAAAAtzc2gtZWQyNTUxOQAAACDV6tAG149uzUDypi8xFrtKueqfn4oWtsThNP2CztT92A
+AAAED1wOXdWGc+XwJ0CJOlUOxDnj5ttVnhIgVH7j82nq1HutXq0AbXj27NQPKmLzEWu0q5
+6p+fiha2xOE0/YLO1P3YAAAACXRvbnlnQHppcAECAwQ=
+-----END OPENSSH PRIVATE KEY-----

syndicate-ssh/test-host-keys/ssh_host_ed25519_key.pub

@@ -0,0 +1 @@
+ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAINXq0AbXj27NQPKmLzEWu0q56p+fiha2xOE0/YLO1P3Y tonyg@zip

syndicate-ssh/test-host-keys/ssh_host_rsa_key

@@ -0,0 +1,38 @@
+-----BEGIN OPENSSH PRIVATE KEY-----
+b3BlbnNzaC1rZXktdjEAAAAABG5vbmUAAAAEbm9uZQAAAAAAAAABAAABlwAAAAdzc2gtcn
+NhAAAAAwEAAQAAAYEA2EWYcvcNyEa/zExJyIGWrt1M3fuM/odsAwdmgn081GLV6wbdKGLf
+1orHiyvV23iKJoLYPmu47mGSCayhBzwx+gmGxpS2HNnkhvs2mfmakOPxBHqQXYtT7eEemM
+zyboVcB1iFyzQaVmAXW3esTewlv6E8hM45XlT+KzifYh0hzn+94vNGb13iQmNTaaqgkoS1
+rfZiaShZPsyXTztC0lBzJkDYBnCkWJEsnDuhMWddRNXrCYytjm0xpU3IgU5jPb1sXyHBVo
+s1VMjeSIJ7KSRmgjCoDpjTG5nwD/b9m/yLIkfJtit5e9jqnFVDZvAIQIDWUPfKm5TZPE4L
+bw8oGOuXgn3JZJIPxc359s7F44gt5NyXrJVj0L57Lcy1Zmn0Qx+0wGQUZBYHrb9OSNB2Kp
+g/OYUZXzba071AXGaKTp3iBM2JVp4/VHiWlSw2H0f+7U9L9VcByYUcVk/a8x/FNEt5JOth
+e9tdsXR9ZCaYU8nDz2EmnxcM7WgwVpBegFoe8ysPAAAFgGz7M1Vs+zNVAAAAB3NzaC1yc2
+EAAAGBANhFmHL3DchGv8xMSciBlq7dTN37jP6HbAMHZoJ9PNRi1esG3Shi39aKx4sr1dt4
+iiaC2D5ruO5hkgmsoQc8MfoJhsaUthzZ5Ib7Npn5mpDj8QR6kF2LU+3hHpjM8m6FXAdYhc
+s0GlZgF1t3rE3sJb+hPITOOV5U/is4n2IdIc5/veLzRm9d4kJjU2mqoJKEta32YmkoWT7M
+l087QtJQcyZA2AZwpFiRLJw7oTFnXUTV6wmMrY5tMaVNyIFOYz29bF8hwVaLNVTI3kiCey
+kkZoIwqA6Y0xuZ8A/2/Zv8iyJHybYreXvY6pxVQ2bwCECA1lD3ypuU2TxOC28PKBjrl4J9
+yWSSD8XN+fbOxeOILeTcl6yVY9C+ey3MtWZp9EMftMBkFGQWB62/TkjQdiqYPzmFGV822t
+O9QFxmik6d4gTNiVaeP1R4lpUsNh9H/u1PS/VXAcmFHFZP2vMfxTRLeSTrYXvbXbF0fWQm
+mFPJw89hJp8XDO1oMFaQXoBaHvMrDwAAAAMBAAEAAAGAZfJgi4jz4T2gecBYY4Das/Ezo8
+xJSU4y1zas1sQMYZ15c0GYDMqW8z4WE/+E3uDyVncFUl9bHFu4CIFsosl4UYIeGwvM0MrR
+k+NleK2Vc8lPOqo/1SixVofw8Vxix0BsAjZzUzdrVt4TBJXkDhNMNAngSkYf+tybt2oIj6
+pl3j6PFyVQRXz/BAZoMn4xFQAj2C41c5aGgzjT9pBbzmIH9bdJXbfJcMp2OetN78jmyWUB
+V04OHf5REbgZ1QJLe7YHOqbrASUU7qkBhDymVT99eFysU5HDbiWvBVCcTJx5dZesVofb0e
+qAKp6669p/m32FqzvNsH/2G5L7ADlYZU34jZEYu4swfpEC2u+j5+sRNSHyZy7D52pgGVox
+FCXxmUm/lxrmoyr7Eehk/jn93efbm4DwogxgyEioi8CL8p1ZWoPDQja1hyHBZohHM5g3pp
+I4pQT+ZAMh2K7hTsELjnb+nsSE2m5c3KxgNE3QGn1YNxJukb5DYpFZoR8U7QnVgYyRAAAA
+wQDathK27D5cnsoUYSpipFkvT8gWcAKOQyV+8s65HdOSgTOBZsb023o9o40nKGmS/UE54A
+OhM4k6o7zfzbIT7kTqaLLs13Vz/Zt0aoR2Q4fBVKu0FN3b695Ee+lqW6lvT//RuOmj7aRZ
++MLXtFTds6GzFTslMYZSpPWGgElHzpm9iJ1r5golQ7ZpnNvU7W+Zg9YEMLCJDJ9aXgU6mG
+5pkMAjs5xTFQxt7JNYtcRUK7NLXtx25t5tlhcfWh/1H5TplHcAAADBAPgj7W62O7IQmF7j
+UfSYFASspq96PKnBw49MZ1wKUPfiWxjxaHOmDnIv7tVSIZZZXWtE7C/cbg/19OyP/D44WI
+nxQLLmpMFKl6PFShK0lZnE9SL8msiv7w9bx/YHDSI4dXdYhqYYLFg9vB18NlUDvJAJmic9
+sMt9h5qq+SZdz1rIM7LU4fZ9ztliRTburWvkAgZ6MLmZJYz2pLaGmG5cpUxXGxgf7PZ1e3
+PWnSgYcF2v60ze9ceHdqA+Plpk7QcPxwAAAMEA3x9CTu8V9irEvO4rayzg9LW6WlIdOmOc
+uH0HryN5asyRinB3MSHUijbJLqdpCfSMo1wqg8VsdiT4k504zyueiVyCn3TGg0MK+7ufme
+k42IlB2xpjVgP2BDg+PU6gocZRJxDTfY7DhOCNttO0r3jWQ2LZ7LJ2uEdnpLqEYLrQtjFn
+p7s2ljom+Eaf21XaPt60JklrFh/F/wPkdWinZSG9dzfOo625NrBxVKwPJ9XuPFAB2gfaSK
+agQGul6z+t6Zp5AAAACXRvbnlnQHppcAE=
+-----END OPENSSH PRIVATE KEY-----

syndicate-ssh/test-host-keys/ssh_host_rsa_key.pub

@@ -0,0 +1 @@
+ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABgQDYRZhy9w3IRr/MTEnIgZau3Uzd+4z+h2wDB2aCfTzUYtXrBt0oYt/WiseLK9XbeIomgtg+a7juYZIJrKEHPDH6CYbGlLYc2eSG+zaZ+ZqQ4/EEepBdi1Pt4R6YzPJuhVwHWIXLNBpWYBdbd6xN7CW/oTyEzjleVP4rOJ9iHSHOf73i80ZvXeJCY1NpqqCShLWt9mJpKFk+zJdPO0LSUHMmQNgGcKRYkSycO6ExZ11E1esJjK2ObTGlTciBTmM9vWxfIcFWizVUyN5IgnspJGaCMKgOmNMbmfAP9v2b/IsiR8m2K3l72OqcVUNm8AhAgNZQ98qblNk8TgtvDygY65eCfclkkg/Fzfn2zsXjiC3k3JeslWPQvnstzLVmafRDH7TAZBRkFgetv05I0HYqmD85hRlfNtrTvUBcZopOneIEzYlWnj9UeJaVLDYfR/7tT0v1VwHJhRxWT9rzH8U0S3kk62F7212xdH1kJphTycPPYSafFwztaDBWkF6AWh7zKw8= tonyg@zip

syndicate-ssh/test-user-key

@@ -0,0 +1,8 @@
+-----BEGIN OPENSSH PRIVATE KEY-----
+b3BlbnNzaC1rZXktdjEAAAAABG5vbmUAAAAEbm9uZQAAAAAAAAABAAAAMwAAAAtzc2gtZW
+QyNTUxOQAAACCDRVaGbNdM5AXoFvvn6yrGQuklQmD4/S9l/MppdALwXAAAAKg3sHCqN7Bw
+qgAAAAtzc2gtZWQyNTUxOQAAACCDRVaGbNdM5AXoFvvn6yrGQuklQmD4/S9l/MppdALwXA
+AAAEAHNSx5h9cI/2fO7JdUaEl4IQiQpsbpdAzSSyvv52NAvINFVoZs10zkBegW++frKsZC
+6SVCYPj9L2X8yml0AvBcAAAAH3Rlc3QgdXNlciBrZXkgZm9yIHN5bmRpY2F0ZS1zc2gBAg
+MEBQY=
+-----END OPENSSH PRIVATE KEY-----

syndicate-ssh/test-user-key.pub

@@ -0,0 +1 @@
+ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIINFVoZs10zkBegW++frKsZC6SVCYPj9L2X8yml0AvBc test user key for syndicate-ssh

test-aes-ctr.rkt

@@ -1,154 +0,0 @@
-#lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(require "aes-ctr.rkt")
-(require rackunit)
-(require bitsyntax)
-
-(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
-		(aes-ctr-process! x #"abcdefghijklmnop"))
-	      #"\275XO-\317^<d\16(\262\257Fv}e" ;; = bd584f2dcf5e3c640e28b2af46767d65
-	      )
-
-(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
-		(let* ((b1 (aes-ctr-process! x #"abcdef"))
-		       (b2 (aes-ctr-process! x #"ghijklmnop")))
-		  (list b1 b2)))
-	      (list #"\275XO-\317^"
-		    #"<d\16(\262\257Fv}e"))
-
-(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
-		(aes-ctr-process! x #"\275XO-\317^<d\16(\262\257Fv}e"))
-	      #"abcdefghijklmnop")
-
-(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
-		(let* ((b1 (aes-ctr-process! x #"\275XO-\317^"))
-		       (b2 (aes-ctr-process! x #"<d\16(\262\257Fv}e")))
-		  (list b1 b2)))
-	      (list #"abcdef"
-		    #"ghijklmnop"))
-
-(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
-		(aes-ctr-process! x #"abcdefghijklmnopabcdefghijklmnop"))
-	      #"\275XO-\317^<d\16(\262\257Fv}e!v\301\23\6@\330\305\314c\27\374\276\330 \342")
-
-(check-equal? (let ((x (start-aes-ctr (make-bytes 16 97) (make-bytes 16 0))))
-		(aes-ctr-process! x
-		 #"\275XO-\317^<d\16(\262\257Fv}e!v\301\23\6@\330\305\314c\27\374\276\330 \342"))
-	      #"abcdefghijklmnopabcdefghijklmnop")
-
-;; Test vectors from http://tools.ietf.org/html/draft-ietf-ipsec-ciph-aes-ctr-05
-
-(define (hex-string->bytes str) ;; grumble
-  (define cleaned (regexp-replace* #rx"[^0-9a-fA-F]+" str ""))
-  (define bits (* (string-length cleaned) 4))
-  (define n (string->number cleaned 16))
-  (integer->bit-string n bits #t))
-
-(define (test-enc description key ivec plaintext ciphertext)
-  (let ((state (start-aes-ctr (hex-string->bytes key)
-			      (hex-string->bytes ivec))))
-    (check-equal? (aes-ctr-process! state (hex-string->bytes plaintext))
-		  (hex-string->bytes ciphertext)
-		  (format "test-enc ~v" description))))
-
-;; Test Vector #1: Encrypting 16 octets using AES-CTR with 128-bit key
-(test-enc 1
- "AE 68 52 F8 12 10 67 CC 4B F7 A5 76 55 77 F3 9E"
- "00 00 00 30 00 00 00 00 00 00 00 00 00 00 00 01"
- "53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
- "E4 09 5D 4F B7 A7 B3 79 2D 61 75 A3 26 13 11 B8")
-
-;; Test Vector #2: Encrypting 32 octets using AES-CTR with 128-bit key
-(test-enc 2
- "7E 24 06 78 17 FA E0 D7 43 D6 CE 1F 32 53 91 63"
- "00 6C B6 DB C0 54 3B 59 DA 48 D9 0B 00 00 00 01"
- (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
-		"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
- (string-append "51 04 A1 06 16 8A 72 D9 79 0D 41 EE 8E DA D3 88"
-		"EB 2E 1E FC 46 DA 57 C8 FC E6 30 DF 91 41 BE 28"))
-
-;; Test Vector #3: Encrypting 36 octets using AES-CTR with 128-bit key
-(test-enc 3
- "76 91 BE 03 5E 50 20 A8 AC 6E 61 85 29 F9 A0 DC"
- "00 E0 01 7B 27 77 7F 3F 4A 17 86 F0 00 00 00 01"
- (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
-		"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
-		"20 21 22 23")
- (string-append "C1 CF 48 A8 9F 2F FD D9 CF 46 52 E9 EF DB 72 D7"
-		"45 40 A4 2B DE 6D 78 36 D5 9A 5C EA AE F3 10 53"
-		"25 B2 07 2F"))
-
-;; Test Vector #4: Encrypting 16 octets using AES-CTR with 192-bit key
-(test-enc 4
- "16 AF 5B 14 5F C9 F5 79 C1 75 F9 3E 3B FB 0E ED 86 3D 06 CC FD B7 85 15"
- "00 00 00 48 36 73 3C 14 7D 6D 93 CB 00 00 00 01"
- "53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
- "4B 55 38 4F E2 59 C9 C8 4E 79 35 A0 03 CB E9 28")
-
-;; Test Vector #5: Encrypting 32 octets using AES-CTR with 192-bit key
-(test-enc 5
- "7C 5C B2 40 1B 3D C3 3C 19 E7 34 08 19 E0 F6 9C 67 8C 3D B8 E6 F6 A9 1A"
- "00 96 B0 3B 02 0C 6E AD C2 CB 50 0D 00 00 00 01"
- (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
-		"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
- (string-append "45 32 43 FC 60 9B 23 32 7E DF AA FA 71 31 CD 9F"
-		"84 90 70 1C 5A D4 A7 9C FC 1F E0 FF 42 F4 FB 00"))
-
-;; Test Vector #6: Encrypting 36 octets using AES-CTR with 192-bit key
-(test-enc 6
- "02 BF 39 1E E8 EC B1 59 B9 59 61 7B 09 65 27 9B F5 9B 60 A7 86 D3 E0 FE"
- "00 07 BD FD 5C BD 60 27 8D CC 09 12 00 00 00 01"
- (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
-		"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
-		"20 21 22 23")
- (string-append "96 89 3F C5 5E 5C 72 2F 54 0B 7D D1 DD F7 E7 58"
-		"D2 88 BC 95 C6 91 65 88 45 36 C8 11 66 2F 21 88"
-		"AB EE 09 35"))
-
-;; Test Vector #7: Encrypting 16 octets using AES-CTR with 256-bit key
-(test-enc 7
- (string-append "77 6B EF F2 85 1D B0 6F 4C 8A 05 42 C8 69 6F 6C"
-		"6A 81 AF 1E EC 96 B4 D3 7F C1 D6 89 E6 C1 C1 04")
- "00 00 00 60 DB 56 72 C9 7A A8 F0 B2 00 00 00 01"
- "53 69 6E 67 6C 65 20 62 6C 6F 63 6B 20 6D 73 67"
- "14 5A D0 1D BF 82 4E C7 56 08 63 DC 71 E3 E0 C0")
-
-;; Test Vector #8: Encrypting 32 octets using AES-CTR with 256-bit key
-(test-enc 8
- (string-append "F6 D6 6D 6B D5 2D 59 BB 07 96 36 58 79 EF F8 86"
-		"C6 6D D5 1A 5B 6A 99 74 4B 50 59 0C 87 A2 38 84")
- "00 FA AC 24 C1 58 5E F1 5A 43 D8 75 00 00 00 01"
- (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
-		"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F")
- (string-append "F0 5E 23 1B 38 94 61 2C 49 EE 00 0B 80 4E B2 A9"
-		"B8 30 6B 50 8F 83 9D 6A 55 30 83 1D 93 44 AF 1C"))
-
-;; Test Vector #9: Encrypting 36 octets using AES-CTR with 256-bit key
-(test-enc 9
- (string-append "FF 7A 61 7C E6 91 48 E4 F1 72 6E 2F 43 58 1D E2"
-		"AA 62 D9 F8 05 53 2E DF F1 EE D6 87 FB 54 15 3D")
- "00 1C C5 B7 51 A5 1D 70 A1 C1 11 48 00 00 00 01"
- (string-append "00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F"
-		"10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F"
-		"20 21 22 23")
- (string-append "EB 6C 52 82 1D 0B BB F7 CE 75 94 46 2A CA 4F AA"
-		"B4 07 DF 86 65 69 FD 07 F4 8C C0 B5 83 D6 07 1F"
-		"1E C0 E6 B8"))

test-asn1-ber.rkt

@@ -1,60 +0,0 @@
-#lang racket/base
-;;
-;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
-;;;
-;;; This file is part of marketplace-ssh.
-;;;
-;;; marketplace-ssh is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; marketplace-ssh is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with marketplace-ssh. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(require rackunit)
-(require "asn1-ber.rkt")
-
-(require bitsyntax)
-
-(define dsa-key
-  #"0\201\336\2@\v\336jE\275\310\266\313y\365\307\e\243\304p\b8l=\3419\227\262\340E\253\333\263%X<\0235\374\30b \367\244\306\253/\22\213b\27\333\203Q\376zS\1\fS\312[\2553\rj\252C-\2A\0\207\26gPqe\245\3632:\5\317\345w\373\v8\231g\3155\376\270\256\f\250c\271\253\2\276\32\365\246\f\265\243\220\36\0302\349\3wI\vZ$I\320\374f\235KX\37\361\235\333\335\236\326\301\2\25\0\215rI\353\212\275\360\222c\365\r\310Z~E\327\337\30\344e\2@.F\2726\24w\352\352%\213~O\2Y\352\246`\246\243\fi\3\v\262\311w\0\211\241.\35\20\377\207F\321\375\354\347\336z3*\241N\347CT\254W98\311'&\204E\277\220\241\343\23sG")
-
-;; #"3081de02400bde6a45bdc8b6cb79f5c71ba3c47008386c3de13997b2e045abdbb325583c1335fc186220f7a4c6ab2f128b6217db8351fe7a53010c53ca5bad330d6aaa432d024100871667507165a5f3323a05cfe577fb0b389967cd35feb8ae0ca863b9ab02be1af5a60cb5a3901e18321c390377490b5a2449d0fc669d4b581ff19ddbdd9ed6c10215008d7249eb8abdf09263f50dc85a7e45d7df18e46502402e46ba361477eaea258b7e4f0259eaa660a6a30c69030bb2c9770089a12e1d10ff8746d1fdece7de7a332aa14ee74354ac573938c927268445bf90a1e3137347"
-
-(define rsa-key
-  #"0H\2A\0\257\247\361\314Jm\317w\325OD\223\263\353h\356\300\211Y\16x\344\361\314N\251\t\26\1S\362\222\205,ifN\374\321\230\355\363L\351\311M\255\335\301W\203\177;[\177\272\357\"p\nl\315\216\5\2\3\1\0\1")
-
-;; #"3048024100afa7f1cc4a6dcf77d54f4493b3eb68eec089590e78e4f1cc4ea909160153f292852c69664efcd198edf34ce9c94dadddc157837f3b5b7fbaef22700a6ccd8e050203010001"
-
-(check-equal? (bit-string (123 :: (t:long-ber-tag))) (bytes 123))
-(check-equal? (bit-string (234 :: (t:long-ber-tag))) (bytes 129 106))
-(check-equal? (bit-string (12345678 :: (t:long-ber-tag))) (bytes 133 241 194 78))
-
-(check-equal? (bit-string-case (bytes 123) ([(v :: (t:long-ber-tag))] v)) 123)
-(check-equal? (bit-string-case (bytes 129 106) ([(v :: (t:long-ber-tag))] v)) 234)
-(check-equal? (bit-string-case (bytes 133 241 194 78) ([(v :: (t:long-ber-tag))] v)) 12345678)
-
-(check-equal? (bit-string->bytes (bit-string (12 :: (t:ber-length-indicator))))
-	      (bytes 12))
-(check-equal? (bit-string->bytes (bit-string (123 :: (t:ber-length-indicator))))
-	      (bytes 123))
-(check-equal? (bit-string->bytes (bit-string (1234 :: (t:ber-length-indicator))))
-	      (bytes 130 4 210))
-(check-equal? (bit-string->bytes (bit-string (12345678 :: (t:ber-length-indicator))))
-	      (bytes 131 188 97 78))
-
-(check-equal? (bit-string-case (bytes 12) ([(v :: (t:ber-length-indicator))] v)) 12)
-(check-equal? (bit-string-case (bytes 123) ([(v :: (t:ber-length-indicator))] v)) 123)
-(check-equal? (bit-string-case (bytes 130 4 210) ([(v :: (t:ber-length-indicator))] v)) 1234)
-(check-equal? (bit-string-case (bytes 131 188 97 78) ([(v :: (t:ber-length-indicator))] v))
-	      12345678)
-
-(check-equal? (asn1-ber-encode (asn1-ber-decode-all dsa-key)) dsa-key)
-(check-equal? (asn1-ber-encode (asn1-ber-decode-all rsa-key)) rsa-key)

test-dsa-key

@@ -1,12 +0,0 @@
------BEGIN DSA PRIVATE KEY-----
-MIIBuwIBAAKBgQCEQ1YvOR7/MQByCPJt/FSO7NN7YO1VLqy7A95M07q6AaG5FZ2A
-m9s8KZPlNFPrNhG8pRxxHhWgfBczoIObZi2saXeXQyTCUtHUejQBk+Xl31I+0SYU
-/m5fIP3Q9UY3cR8LucsIQkJIcuLVpoMmtFA/EtxYs+roxm+wtMlgk/8HkQIVAObN
-DEIjvgKwW9MKzRz8VXms/aDDAoGAeMnKQxj/iBSfQ3Wsd4ipCi3PdoLJ0+TJuiFG
-0tmbxLxwC0YCR24YMeobva/SpSu6y48+2rjv9Wc9ZKwISbrdO6xrNgDJtoCZLGK+
-C2DHEC3rBYFicOgpoysk/HsS/to3GtMnPyA2NJDR/cjUdgWBRg+4eAx1ZsVPjaJT
-A5Z60tECgYAkhzk5oi/b3zxPEPoFYki2apR4mciJso/1mYvb6fpd+rzlihNrkFAA
-LL+6uOofkyf32FIQhEN+JXDNMfaHreJkLPxGXIJ4FyUbrrZcxbmgJdh9NHd0L/mI
-yIHlo+SImp1DLCEtRP1GwKv8Lm0/rFNpY/z5Os3qeXKw1swDvEMfywIVANtH4mhn
-F6JfX/4/cJ4cpGlcgrWe
------END DSA PRIVATE KEY-----