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

Compare commits

base: syndicate-lang:pre-typed-kernel
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:main
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

2 Commits
pre-typed- ... main

Author SHA1 Message Date
Tony Garnock-Jones f988d5a864 Simple makefile 2013-04-09 13:39:25 -04:00
Tony Garnock-Jones e4f13155a4 Update for new bitsyntax extension API 2013-04-09 13:39:16 -04:00
3 changed files with 81 additions and 74 deletions
Show Stats Expand all files Collapse all files

5
Makefile Normal file
View File

@ -0,0 +1,5 @@
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) read-long-tag) ((_ #t input ks kf) (read-long-tag input ks kf))
((_ #f) write-long-tag))) ((_ #f v) (write-long-tag v))))
(define (read-long-tag input ks kf) (define (read-long-tag input ks kf)
(let loop ((acc 0) (let loop ((acc 0)
@ -51,33 +51,34 @@
(define-syntax t:ber-length-indicator (define-syntax t:ber-length-indicator
(syntax-rules () (syntax-rules ()
((_ #t) (lambda (input ks kf) ((_ #t input ks0 kf)
(bit-string-case input (let ((ks ks0)) ;; avoid code explosion
([ (= 128 :: bits 8) (bit-string-case input
(rest :: binary) ] ([ (= 128 :: bits 8)
(ks 'indefinite rest)) (rest :: binary) ]
([ (= 0 :: bits 1) (ks 'indefinite rest))
(len :: bits 7) ([ (= 0 :: bits 1)
(rest :: binary) ] (len :: bits 7)
(ks len rest)) (rest :: binary) ]
([ (= 1 :: bits 1) (ks len rest))
(lenlen :: bits 7) ([ (= 1 :: bits 1)
(len :: integer bytes lenlen) (lenlen :: bits 7)
(rest :: binary) ] (len :: integer bytes lenlen)
(when (not (= lenlen 127))) ;; restriction from section 8.1.3.5 (rest :: binary) ]
(ks len rest)) (when (not (= lenlen 127))) ;; restriction from section 8.1.3.5
(else (kf))))) (ks len rest))
((_ #f) (lambda (len) (else (kf)))))
(cond ((_ #f len)
((eq? len 'indefinite) (cond
(bytes 128)) ((eq? len 'indefinite)
((< len 128) (bytes 128))
(bytes len)) ((< len 128)
(else (bytes len))
(let ((lenlen (quotient (+ 7 (integer-length len)) 8))) (else
(bit-string (1 :: bits 1) (let ((lenlen (quotient (+ 7 (integer-length len)) 8)))
(lenlen :: bits 7) (bit-string (1 :: bits 1)
(len :: integer bytes lenlen))))))))) (lenlen :: bits 7)
(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,63 +74,64 @@
(define-syntax t:boolean (define-syntax t:boolean
(syntax-rules () (syntax-rules ()
((_ #t) (lambda (input ks kf) ((_ #t 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) (lambda (v) (bit-string (if v 1 0)))))) ((_ #f v) (bit-string (if v 1 0)))))
(define-syntax t:packed-bytes (define-syntax t:packed-bytes
(syntax-rules () (syntax-rules ()
((_ #t n) (lambda (input ks kf) ((_ #t input ks kf n)
(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) (lambda (input ks kf) ((_ #t 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 n) (lambda (bs) (bit-string (bs :: binary)))) ((_ #f bs n) (bit-string (bs :: binary)))
((_ #f) (lambda (bs) (bit-string (bs :: binary)))))) ((_ #f bs) (bit-string (bs :: binary)))))
(define-syntax t:string (define-syntax t:string
(syntax-rules () (syntax-rules ()
((_ #t #:pack) (lambda (input ks kf) ((_ #t input ks kf #:pack)
((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) (lambda (input ks kf) ((_ #t 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 #:pack) (t:string #f)) ;; #:pack ignored on encoding ((_ #f bs #:pack) (t:string #f bs)) ;; #:pack ignored on encoding
((_ #f) (lambda (bs) ((_ #f 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) (lambda (input ks kf) ((_ #t 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) (lambda (n) ((_ #f 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) (lambda (input ks kf) ((_ #t input ks kf)
((t:string #t) input (t:string #t
(lambda (body rest) (ks (name-list->symbols body) rest)) input
kf))) (lambda (body rest) (ks (name-list->symbols body) rest))
((_ #f) (lambda (ns) kf))
((t:string #f) (symbols->name-list ns)))))) ((_ #f 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)