Simple makefile

Makefile

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

asn1-ber.rkt

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

ssh-message-types.rkt

@@ -74,63 +74,64 @@
 
 (define-syntax t:boolean
   (syntax-rules ()
-    ((_ #t) (lambda (input ks kf)
-	      (bit-string-case input
-		([ v (rest :: binary) ]
-		 (ks (not (zero? v)) rest))
-		(else (kf)))))
-    ((_ #f) (lambda (v) (bit-string (if v 1 0))))))
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ v (rest :: binary) ]
+	(ks (not (zero? v)) rest))
+       (else (kf))))
+    ((_ #f v) (bit-string (if v 1 0)))))
 
 (define-syntax t:packed-bytes
   (syntax-rules ()
-    ((_ #t n) (lambda (input ks kf)
-		(bit-string-case input
-		  ([ (bs :: binary bytes n) (rest :: binary) ]
-		   (ks (bit-string->bytes bs) rest))
-		  (else (kf)))))
-    ((_ #t) (lambda (input ks kf)
-	      (bit-string-case input
-		([ (rest :: binary) ]
-		 (ks (bit-string->bytes rest) #""))
-		(else (kf)))))
-    ((_ #f n) (lambda (bs) (bit-string (bs :: binary))))
-    ((_ #f) (lambda (bs) (bit-string (bs :: binary))))))
+    ((_ #t input ks kf n)
+     (bit-string-case input
+       ([ (bs :: binary bytes n) (rest :: binary) ]
+	(ks (bit-string->bytes bs) rest))
+       (else (kf))))
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ (rest :: binary) ]
+	(ks (bit-string->bytes rest) #""))
+       (else (kf))))
+    ((_ #f bs n) (bit-string (bs :: binary)))
+    ((_ #f bs) (bit-string (bs :: binary)))))
 
 (define-syntax t:string
   (syntax-rules ()
-    ((_ #t #:pack) (lambda (input ks kf)
-		     ((t:string #t) input (lambda (v rest) (ks (bit-string->bytes v) rest)) kf)))
-    ((_ #t) (lambda (input ks kf)
-	      (bit-string-case input
-		([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
-		 (ks body rest))
-		(else (kf)))))
-    ((_ #f #:pack) (t:string #f)) ;; #:pack ignored on encoding
-    ((_ #f) (lambda (bs)
-	      (bit-string ((bytes-length (bit-string->bytes bs)) :: integer bits 32)
-			  (bs :: binary))))))
+    ((_ #t input ks kf #:pack)
+     (t:string #t input (lambda (v rest) (ks (bit-string->bytes v) rest)) kf))
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
+	(ks body rest))
+       (else (kf))))
+    ((_ #f bs #:pack) (t:string #f bs)) ;; #:pack ignored on encoding
+    ((_ #f bs)
+     (bit-string ((bytes-length (bit-string->bytes bs)) :: integer bits 32)
+		 (bs :: binary)))))
 
 (define-syntax t:mpint
   (syntax-rules ()
-    ((_ #t) (lambda (input ks kf)
-	      (bit-string-case input
-		([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
-		 (ks (if (zero? (bit-string-length body)) 0 (bit-string->integer body #t #t))
-		     rest))
-		(else (kf)))))
-    ((_ #f) (lambda (n)
-	      (let* ((width (mpint-width n))
-		     (buf (integer->bit-string n (* 8 width) #t)))
-		(bit-string (width :: integer bits 32) (buf :: binary)))))))
+    ((_ #t input ks kf)
+     (bit-string-case input
+       ([ (length :: integer bits 32) (body :: binary bytes length) (rest :: binary) ]
+	(ks (if (zero? (bit-string-length body)) 0 (bit-string->integer body #t #t))
+	    rest))
+       (else (kf))))
+    ((_ #f n)
+     (let* ((width (mpint-width n))
+	    (buf (integer->bit-string n (* 8 width) #t)))
+       (bit-string (width :: integer bits 32) (buf :: binary))))))
 
 (define-syntax t:name-list
   (syntax-rules ()
-    ((_ #t) (lambda (input ks kf)
-	      ((t:string #t) input
-	                     (lambda (body rest) (ks (name-list->symbols body) rest))
-			     kf)))
-    ((_ #f) (lambda (ns)
-	      ((t:string #f) (symbols->name-list ns))))))
+    ((_ #t input ks kf)
+     (t:string #t
+	       input
+	       (lambda (body rest) (ks (name-list->symbols body) rest))
+	       kf))
+    ((_ #f ns)
+     (t:string #f (symbols->name-list ns)))))
 
 (define-for-syntax (codec-options field-type)
   (syntax-case field-type (byte boolean uint32 uint64 string mpint name-list)