syndicate-lang
/
racket-ssh-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Compare commits

base: syndicate-lang:main
Branches Tags
syndicate-lang:main
syndicate-lang:cleanup-for-github
syndicate-lang:marketplace
syndicate-lang:typed-kernel
syndicate-lang:moved-to-github
syndicate-lang:pre-cleanup-for-github
syndicate-lang:pre-typed-kernel
syndicate-lang:pre-os2
syndicate-lang:pre-os-big-bang
..
compare: syndicate-lang:typed-kernel
Branches Tags
syndicate-lang:cleanup-for-github
syndicate-lang:marketplace
syndicate-lang:main
syndicate-lang:typed-kernel
syndicate-lang:moved-to-github
syndicate-lang:pre-cleanup-for-github
syndicate-lang:pre-typed-kernel
syndicate-lang:pre-os2
syndicate-lang:pre-os-big-bang

No commits in common. "main" and "typed-kernel" have entirely different histories.
main ... typed-kern

3 changed files with 74 additions and 81 deletions
Show Stats Expand all files Collapse all files

5
Makefile
View File

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

59
asn1-ber.rkt
View File

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

91
ssh-message-types.rkt
View File

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