From df0c210e4b53d0855c3f6935d282009f718cc83d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 13 Mar 2013 17:04:08 -0400 Subject: [PATCH] Update to new bitsyntax extension interface. --- codec.rkt | 161 ++++++++++++++++++++++++++---------------------------- 1 file changed, 76 insertions(+), 85 deletions(-) diff --git a/codec.rkt b/codec.rkt index 40894da..c784c68 100644 --- a/codec.rkt +++ b/codec.rkt @@ -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))))))) ;; ;; 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)))))) ;; ;; 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))))) ;; ;; 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.