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

Update to new bitsyntax extension interface.

This commit is contained in:
Tony Garnock-Jones 2013-03-13 17:04:08 -04:00
parent 7aa56a424d
commit df0c210e4b
1 changed files with 76 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

161
codec.rkt
View File

@ -68,19 +68,18 @@
;; (bit-string (vals :: (t:ntimes bits 32))) ;; (bit-string (vals :: (t:ntimes bits 32)))
(define-syntax t:ntimes (define-syntax t:ntimes
(syntax-rules () (syntax-rules ()
((_ #t times-to-repeat option ...) ((_ #t input ks kf times-to-repeat option ...)
(lambda (input ks kf) (let loop ((count times-to-repeat)
(let loop ((count times-to-repeat) (acc '())
(acc '()) (input input))
(input input)) (cond
(cond ((positive? count) (bit-string-case input
((positive? count) (bit-string-case input ([ (v :: option ...) (rest :: binary) ]
([ (v :: option ...) (rest :: binary) ] (loop (- count 1) (cons v acc) rest))
(loop (- count 1) (cons v acc) rest)) (else (kf))))
(else (kf)))) (else (ks (reverse acc) input)))))
(else (ks (reverse acc) input)))))) ((_ #f vs option ...)
((_ #f option ...) (t:listof #f vs option ...))))
(t:listof #f option ...))))
;; Bit-syntax type for repeats of a value until no more input available. ;; Bit-syntax type for repeats of a value until no more input available.
;; Example: List of 32-bit unsigned words: ;; Example: List of 32-bit unsigned words:
@ -88,24 +87,22 @@
;; (bit-string (vals :: (t:listof bits 32))) ;; (bit-string (vals :: (t:listof bits 32)))
(define-syntax t:listof (define-syntax t:listof
(syntax-rules () (syntax-rules ()
((_ #t option ...) ((_ #t input ks kf option ...)
(lambda (input ks kf) (let loop ((acc '())
(let loop ((acc '()) (input input))
(input input)) (bit-string-case input
(bit-string-case input ([ (v :: option ...) (rest :: binary) ]
([ (v :: option ...) (rest :: binary) ] (loop (cons v acc) rest))
(loop (cons v acc) rest)) ([]
([] (ks (reverse acc) #""))
(ks (reverse acc) #"")) (else
(else (kf)))))
(kf)))))) ((_ #f vs option ...)
((_ #f option ...) (let loop ((vs vs))
(lambda (vs) (cond
(let loop ((vs vs)) ((pair? vs) (bit-string ((car vs) :: option ...)
(cond ((loop (cdr vs)) :: binary)))
((pair? vs) (bit-string ((car vs) :: option ...) (else (bit-string)))))))
((loop (cdr vs)) :: binary)))
(else (bit-string))))))))
;; <rfc1035> ;; <rfc1035>
;; All communications inside of the domain protocol are carried in a single ;; All communications inside of the domain protocol are carried in a single
@ -206,18 +203,18 @@
;; (bit-string (v :: (t:named-bit 'zero 'one))) ;; (bit-string (v :: (t:named-bit 'zero 'one)))
(define-syntax t:named-bit (define-syntax t:named-bit
(syntax-rules () (syntax-rules ()
((_ #t name0 name1) (lambda (input ks kf) ((_ #t input ks kf name0 name1)
(bit-string-case input (bit-string-case input
([ (v :: bits 1) (rest :: binary) ] ([ (v :: bits 1) (rest :: binary) ]
(ks (if (zero? v) name0 name1) rest)) (ks (if (zero? v) name0 name1) rest))
(else (kf))))) (else (kf))))
((_ #f name0 name1) (lambda (v) ((_ #f v name0 name1)
(cond (cond
((eq? v name1) (bit-string (1 :: bits 1))) ((eq? v name1) (bit-string (1 :: bits 1)))
((eq? v name0) (bit-string (0 :: bits 1))) ((eq? v name0) (bit-string (0 :: bits 1)))
(else (error 't:named-bit (else (error 't:named-bit
"Value supplied is neither ~v nor ~v: ~v" "Value supplied is neither ~v nor ~v: ~v"
name0 name1 v))))))) name0 name1 v))))))
;; Bit-syntax type for a DomainName. When decoding (but not when ;; Bit-syntax type for a DomainName. When decoding (but not when
;; encoding!), we support DNS's weird compressed domain-name syntax; ;; encoding!), we support DNS's weird compressed domain-name syntax;
@ -225,12 +222,11 @@
;; let it refer to random substrings within the packet. ;; let it refer to random substrings within the packet.
(define-syntax t:domain-name (define-syntax t:domain-name
(syntax-rules () (syntax-rules ()
((_ #t whole-packet) ((_ #t input ks kf whole-packet)
(lambda (input ks kf) (let-values (((name rest) (parse-domain-name whole-packet input '())))
(let-values (((name rest) (parse-domain-name whole-packet input '()))) (ks (domain name) rest)))
(ks (domain name) rest)))) ((_ #f val)
((_ #f) (encode-domain-name val))))
encode-domain-name)))
;; DomainName -> Bitstring ;; DomainName -> Bitstring
(define (encode-domain-name name) (define (encode-domain-name name)
@ -272,20 +268,18 @@
;; the given maximum, an error is signalled. ;; the given maximum, an error is signalled.
(define-syntax t:pascal-string (define-syntax t:pascal-string
(syntax-rules () (syntax-rules ()
((_ #t) ((_ #t input ks kf)
(lambda (input ks kf) (bit-string-case input
(bit-string-case input ([ len (body :: binary bytes len) (rest :: binary) ]
([ len (body :: binary bytes len) (rest :: binary) ] (ks (bit-string->bytes body) rest))
(ks (bit-string->bytes body) rest)) (else (kf))))
(else (kf))))) ((_ #f s)
((_ #f) (t:pascal-string #f s "Character-string" 256))
(t:pascal-string #f "Character-string" 256)) ((_ #f s string-kind length-limit)
((_ #f string-kind length-limit) (let ((len (bytes-length s)))
(lambda (s) (when (>= len length-limit)
(let ((len (bytes-length s))) (error 't:pascal-string "~s too long: ~v" string-kind s))
(when (>= len length-limit) (bit-string len (s :: binary))))))
(error 't:pascal-string "~s too long: ~v" string-kind s))
(bit-string len (s :: binary)))))))
;; <rfc1035> ;; <rfc1035>
;; The question section is used to carry the "question" in most queries, ;; The question section is used to carry the "question" in most queries,
@ -309,23 +303,21 @@
;; whole packet because the question may contain nested domain-names. ;; whole packet because the question may contain nested domain-names.
(define-syntax t:question (define-syntax t:question
(syntax-rules () (syntax-rules ()
((_ #t whole-packet) ((_ #t input ks kf whole-packet)
(lambda (input ks kf) (bit-string-case input
(bit-string-case input ([ (qname :: (t:domain-name whole-packet))
([ (qname :: (t:domain-name whole-packet)) (qtype :: bits 16)
(qtype :: bits 16) (qclass :: bits 16)
(qclass :: bits 16) (tail :: binary) ]
(tail :: binary) ] (ks (question qname
(ks (question qname (value->qtype qtype)
(value->qtype qtype) (value->qclass qclass)
(value->qclass qclass) #f)
#f) tail))))
tail))))) ((_ #f q)
((_ #f) (bit-string ((question-name q) :: (t:domain-name))
(lambda (q) ((qtype->value (question-type q)) :: bits 16)
(bit-string ((question-name q) :: (t:domain-name)) ((qclass->value (question-class q)) :: bits 16)))))
((qtype->value (question-type q)) :: bits 16)
((qclass->value (question-class q)) :: bits 16))))))
;; <rfc1035> ;; <rfc1035>
;; All RRs have the same top level format shown below: ;; All RRs have the same top level format shown below:
@ -356,11 +348,10 @@
;; packet because the RR may contain nested domain-names. ;; packet because the RR may contain nested domain-names.
(define-syntax t:rr (define-syntax t:rr
(syntax-rules () (syntax-rules ()
((_ #t whole-packet) ((_ #t input ks kf whole-packet)
(lambda (input ks kf) (decode-rr whole-packet input ks kf))
(decode-rr whole-packet input ks kf))) ((_ #f rr)
((_ #f) (encode-rr rr))))
encode-rr)))
;; Bytes Bytes (RR Bytes -> A) ( -> A) -> A ;; Bytes Bytes (RR Bytes -> A) ( -> A) -> A
;; Helper for t:rr. ;; Helper for t:rr.