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