diff --git a/TODO b/TODO new file mode 100644 index 0000000..6361eb1 --- /dev/null +++ b/TODO @@ -0,0 +1,2 @@ +Make RData and RRType the same thing so it becomes impossible to make +a mistake. diff --git a/api.rkt b/api.rkt new file mode 100644 index 0000000..264d8f3 --- /dev/null +++ b/api.rkt @@ -0,0 +1,127 @@ +#lang racket/base +;; Definitions for use in the API to the functionality of the library. + +(provide (struct-out question) + (struct-out rr) + + (struct-out hinfo) + (struct-out minfo) + (struct-out mx) + (struct-out soa) + (struct-out wks) + (struct-out srv) + + type->value value->type + qtype->value value->qtype + class->value value->class + qclass->value value->qclass) + +(require "mapping.rkt") + +;; A QueryResponder is a (Question -> Either, Failure>), a +;; function from DNS query to DNS response or failure. + +;; A DomainName is a ListOf, representing a domain name. The +;; head of the list is the leftmost label; for example, www.google.com +;; is represented as '(#"www" #"google" #"com"). + +;; A ShortString is a String with length 255 or shorter. + +;; An IPv4 is a (vector Byte Byte Byte Byte), representing an IPv4 +;; address. For example, 127.0.0.1 is represented as (vector 127 0 0 +;; 1). + +;; An IPv6 is a Vector of length 16 containing Bytes, representing an +;; IPv6 address. For example, 2001:0db8:85a3:0000:0000:8a2e:0370:7334 +;; is represented as (vector #x20 #x01 #x0d #xb8 #x85 #xa3 #x00 #x00 +;; #x00 #x00 #x8a #x2e #x03 #x70 #x73 #x34). + +;; A Question is a (question DomainName QueryType QueryClass), +;; representing a DNS question: "What are the RRs for the given name, +;; type and class?" +(struct question (name type class) #:transparent) + +;; An RR is a (rr DomainName RRType RRClass Uint32 RData), +;; representing a resource record. +(struct rr (name type class ttl rdata) #:transparent) + +;; An RData is one of +;; - an IPv4, an "A" record +;; - an IPv6, an "AAAA" record +;; - (hinfo ShortString ShortString), a host information record [O] +;; - (minfo DomainName DomainName), a mailbox information record [O] +;; - (mx Uint16 DomainName), a mail exchanger record +;; - (soa DomainName DomainName Uint32 Uint32 Uint32 Uint32 Uint32), a +;; start-of-authority record +;; - (wks IPv4 Byte Bytes), a Well-Known Service [O] +;; - (srv Uint16 Uint16 Uint16 DomainName), an "SRV" record +;; - a Bytes, either a 'null type RR or any unrecognised RR type. +;; +;; In each case, the RData's variant MUST line up correctly with the +;; type field of any RR containing it. +;; +;; Many of these variants are obsolete in today's DNS database (marked +;; [O] above). +(struct hinfo (cpu os) #:transparent) +(struct minfo (rmailbx emailbx) #:transparent) +(struct mx (preference exchange) #:transparent) +(struct soa (mname rname serial refresh retry expire minimum) #:transparent) +(struct wks (address protocol bitmap) #:transparent) +(struct srv (priority weight port target) #:transparent) + +;; An RRType is a Symbol or a Number, one of the possibilities given +;; in the following define-mapping. It represents the type of an +;; RR. When used in an RR with an RData, the RRType and the RData +;; variant must correspond. +(define-mapping type->value value->type + #:forward-default values + #:backward-default values + (a 1) + (ns 2) + (md 3) + (mf 4) + (cname 5) + (soa 6) + (mb 7) + (mg 8) + (mr 9) + (null 10) + (wks 11) + (ptr 12) + (hinfo 13) + (minfo 14) + (mx 15) + (txt 16) + (aaaa 28) + (srv 33)) + +;; A QueryType is a Symbol or Number (as given in the following +;; define-mapping) or an RRType. It specifies the kinds of records +;; being sought after in a DNS query. +(define-mapping qtype->value value->qtype + #:forward-default type->value + #:backward-default value->type + (axfr 252) + (mailb 253) + (maila 254) + (* 255)) + +;; An RRClass is a Symbol or a Number, one of the possibilities given +;; in the following define-mapping. It represents the "class" of DNS +;; records being discussed. All classes except 'in are obsolete in +;; today's DNS databases. +(define-mapping class->value value->class + #:forward-default values + #:backward-default values + (in 1) + (cs 2) + (ch 3) + (hs 4)) + +;; A QueryClass is a Symbol or Number (as given in the following +;; define-mapping) or an RRClass. It specifies the "class" of records +;; being sought after in a DNS query. +(define-mapping qclass->value value->qclass + #:forward-default class->value + #:backward-default value->class + (* 255)) diff --git a/codec.rkt b/codec.rkt new file mode 100644 index 0000000..01e0edb --- /dev/null +++ b/codec.rkt @@ -0,0 +1,462 @@ +#lang racket/base +;; DNS wire-protocol codec. + +(provide value->query-opcode query-opcode->value + value->query-response-code query-response-code->value + + (struct-out dns-message) + + packet->dns-message + dns-message->packet) + +(require "api.rkt") +(require "mapping.rkt") + +(require racket/match) +(require (planet tonyg/bitsyntax)) + +;; An Opcode is a Symbol or a Number, one of the possibilities given +;; in the following define-mapping. It represents a DNS message +;; operation; see the RFC for details. +(define-mapping value->query-opcode query-opcode->value + #:forward-default values + #:backward-default values + (0 query) + (1 iquery) + (2 status)) + +;; A ResponseCode is a Symbol or a Number, one of the possibilities +;; given in the following define-mapping. It represents the outcome of +;; a DNS query. +(define-mapping value->query-response-code query-response-code->value + (0 no-error) + (1 format-error) + (2 server-failure) + (3 name-error) + (4 not-implemented) + (5 refused)) + +;; A DNSMessage is a +;; (dns-message Uint16 Direction Opcode Authoritativeness +;; Truncatedness RecursionDesired RecursionAvailable ResponseCode +;; ListOf ListOf ListOf ListOf). +;; +;; Interpreted as either a DNS request or reply, depending on the +;; Direction. +(struct dns-message (id + direction + opcode + authoritative + truncated + recursion-desired + recursion-available + response-code + questions + answers + authorities + additional) + #:transparent) + +;; Bit-syntax type for counted repeats of a value. +;; Example: Length-prefixed list of 32-bit unsigned words: +;; (bit-string-case input ([ len (vals :: (t:ntimes len bits 32)) ] vals)) +;; (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 ...)))) + +;; Bit-syntax type for repeats of a value until no more input available. +;; Example: List of 32-bit unsigned words: +;; (bit-string-case input ([ (vals :: (t:listof bits 32)) ] vals)) +;; (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)))))))) + +;; +;; All communications inside of the domain protocol are carried in a single +;; format called a message. The top level format of message is divided +;; into 5 sections (some of which are empty in certain cases) shown below: +;; +;; +---------------------+ +;; | Header | +;; +---------------------+ +;; | Question | the question for the name server +;; +---------------------+ +;; | Answer | RRs answering the question +;; +---------------------+ +;; | Authority | RRs pointing toward an authority +;; +---------------------+ +;; | Additional | RRs holding additional information +;; +---------------------+ +;; + +;; +;; The header contains the following fields: +;; +;; 1 1 1 1 1 1 +;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | ID | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; |QR| Opcode |AA|TC|RD|RA| Z | RCODE | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | QDCOUNT | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | ANCOUNT | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | NSCOUNT | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | ARCOUNT | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; + +;; Bytes -> DNSMessage +;; Parse an encoded DNS message packet into the corresponding Racket +;; structure. Raises an exception on failure. +(define (packet->dns-message packet) + (bit-string-case packet + ([ (id :: bits 16) + (qr :: (t:named-bit 'request 'response)) + (opcode :: bits 4) + (aa :: (t:named-bit 'non-authoritative 'authoritative)) + (tc :: (t:named-bit 'not-truncated 'truncated)) + (rd :: (t:named-bit 'no-recursion-desired 'recursion-desired)) + (ra :: (t:named-bit 'no-recursion-available 'recursion-available)) + (= 0 :: bits 3) + (rcode :: bits 4) + (qdcount :: bits 16) + (ancount :: bits 16) + (nscount :: bits 16) + (arcount :: bits 16) + (q-section :: (t:ntimes qdcount (t:question packet))) + (a-section :: (t:ntimes ancount (t:rr packet))) + (auth-section :: (t:ntimes nscount (t:rr packet))) + (additional-section :: (t:ntimes arcount (t:rr packet))) ] + (dns-message id qr (value->query-opcode opcode) + aa tc rd ra + (value->query-response-code rcode) + q-section a-section auth-section additional-section)))) + +;; DNSMessage -> Bytes +;; Render a Racket structured DNS message using the DNS binary encoding. +(define (dns-message->packet m) + (bit-string->bytes + (bit-string ((dns-message-id m) :: bits 16) + ((dns-message-direction m) :: (t:named-bit 'request 'response)) + ((query-opcode->value (dns-message-opcode m)) :: bits 4) + ((dns-message-authoritative m) :: (t:named-bit 'non-authoritative 'authoritative)) + ((dns-message-truncated m) :: (t:named-bit 'not-truncated 'truncated)) + ((dns-message-recursion-desired m) + :: (t:named-bit 'no-recursion-desired 'recursion-desired)) + ((dns-message-recursion-available m) + :: (t:named-bit 'no-recursion-available 'recursion-available)) + (0 :: bits 3) + ((query-response-code->value (dns-message-response-code m)) :: bits 4) + ((length (dns-message-questions m)) :: bits 16) + ((length (dns-message-answers m)) :: bits 16) + ((length (dns-message-authorities m)) :: bits 16) + ((length (dns-message-additional m)) :: bits 16) + ((dns-message-questions m) :: (t:ntimes (t:question))) + ((dns-message-answers m) :: (t:ntimes (t:rr))) + ((dns-message-authorities m) :: (t:ntimes (t:rr))) + ((dns-message-additional m) :: (t:ntimes (t:rr)))))) + +;; Bit-syntax type for a single bit, represented in Racket as one of +;; two possible symbolic values. +;; Example: a bit represented by 'zero when it is zero, and 'one when it is one. +;; (bit-string-case input ([ (v :: (t:named-bit 'zero 'one)) ] v)) +;; (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))))))) + +;; Bit-syntax type for a DomainName. When decoding (but not when +;; encoding!), we support DNS's weird compressed domain-name syntax; +;; this requires us to pass in the *whole packet* to the decoder to +;; 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 name rest)))) + ((_ #f) + encode-domain-name))) + +;; DomainName -> Bitstring +(define (encode-domain-name labels) + (bit-string (labels :: (t:listof (t:pascal-string "Label" 64))))) + +;; Bytes Bytes ListOf -> DomainName +;; PRECONDITION: input never empty +;; INVARIANT: pointers-followed contains every "jump target" we have +;; jumped to so far during decoding of this domain-name, in order to +;; prevent us from getting stuck in a pointer loop. It should start as +;; the empty list. +(define (parse-domain-name whole-packet input pointers-followed) + (bit-string-case input + + ([(= 3 :: bits 2) (offset :: bits 14) (rest :: binary)] + (if (member offset pointers-followed) + (error 'parse-domain-name "DNS compressed-pointer loop detected") + (let-values (((lhs rhs) (bit-string-split-at whole-packet (* 8 offset)))) + (let-values (((labels ignored-tail) + (parse-domain-name whole-packet rhs (cons offset pointers-followed)))) + (values labels rest))))) + + ([(= 0 :: bits 8) (rest :: binary)] + (values '() rest)) + + ([(= 0 :: bits 2) (len :: bits 6) (label :: binary bytes len) (rest :: binary)] + ;; TODO: validate labels: make sure they conform to the prescribed syntax + (let-values (((labels leftover) + (parse-domain-name whole-packet rest pointers-followed))) + (values (cons (bit-string->bytes label) labels) leftover))))) + +;; Bit-syntax type for single-byte-length-prefixed strings of +;; bytes. No character codec is applied to the bytes. During encoding, +;; expects two extra arguments: the name of the kind of value, for use +;; in error reports, and the maximum permissible length (plus one). If +;; the encoder is given a string of length greater than or equal to +;; 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))))))) + +;; +;; The question section is used to carry the "question" in most queries, +;; i.e., the parameters that define what is being asked. The section +;; contains QDCOUNT (usually 1) entries, each of the following format: +;; +;; 1 1 1 1 1 1 +;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | | +;; / QNAME / +;; / / +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | QTYPE | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | QCLASS | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; + +;; Bit-syntax type for Questions. The decoder needs to be given the +;; 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)) + 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)))))) + +;; +;; All RRs have the same top level format shown below: +;; +;; 1 1 1 1 1 1 +;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | | +;; / / +;; / NAME / +;; | | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | TYPE | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | CLASS | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | TTL | +;; | | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; | RDLENGTH | +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--| +;; / RDATA / +;; / / +;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +;; + +;; Bit-syntax type for RRs. The decoder needs to be given the whole +;; 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))) + +;; Bytes Bytes (RR Bytes -> A) ( -> A) -> A +;; Helper for t:rr. +(define (decode-rr whole-packet input ks kf) + (bit-string-case input + ([ (name :: (t:domain-name whole-packet)) + (type-number :: bits 16) + (class :: bits 16) + (ttl :: bits 32) + (rdlength :: bits 16) + (rdata :: binary bytes rdlength) + (tail :: binary) ] + (let ((type (value->type type-number))) + (ks (rr name + type + (value->class class) + ttl + (decode-rdata whole-packet type rdata)) + tail))) + (else (kf)))) + +;; RR -> Bitstring +;; Helper for t:rr. +(define (encode-rr rr) + (let ((encoded-rdata (encode-rdata (rr-type rr) (rr-rdata rr)))) + (bit-string ((rr-name rr) :: (t:domain-name)) + ((type->value (rr-type rr)) :: bits 16) + ((class->value (rr-class rr)) :: bits 16) + ((rr-ttl rr) :: bits 32) + ((/ (bit-string-length encoded-rdata) 8) :: bits 16) + (encoded-rdata :: binary)))) + +;; Bytes RRType Bytes -> RData +;; Decode RData according to the RRType. Takes the whole packet for +;; the same reason as t:rr does. +(define (decode-rdata whole-packet type rdata) + (case type + ((cname mb md mf mg mr ns ptr) (bit-string-case rdata + ([ (name :: (t:domain-name whole-packet)) ] name))) + ((hinfo) (bit-string-case rdata + ([ (cpu :: (t:pascal-string)) (os :: (t:pascal-string)) ] + (hinfo cpu os)))) + ((minfo) (bit-string-case rdata + ([ (rmailbx :: (t:domain-name whole-packet)) + (emailbx :: (t:domain-name whole-packet)) ] + (minfo rmailbx emailbx)))) + ((mx) (bit-string-case rdata + ([ (preference :: bits 16) + (exchange :: (t:domain-name whole-packet)) ] + (mx preference exchange)))) + ((null) (bit-string->bytes rdata)) + ((soa) (bit-string-case rdata + ([ (mname :: (t:domain-name whole-packet)) + (rname :: (t:domain-name whole-packet)) + (serial :: bits 32) + (refresh :: bits 32) + (retry :: bits 32) + (expire :: bits 32) + (minimum :: bits 32) ] + (soa mname rname serial refresh retry expire minimum)))) + ((txt) (bit-string-case rdata + ([ (strs :: (t:listof (t:pascal-string))) ] + strs))) + ((a) (bit-string-case rdata + ([ a b c d ] + (vector a b c d)))) + ((aaaa) (bit-string-case rdata + ([ (ipv6-addr :: binary bits 128) ] + (list->vector (bytes->list (bit-string->bytes ipv6-addr)))))) + ((wks) (bit-string-case rdata + ([ a b c d protocol (bitmap :: binary) ] + (wks (vector a b c d) protocol bitmap)))) + ((srv) (bit-string-case rdata + ([ (priority :: bits 16) + (weight :: bits 16) + (port :: bits 16) + (target :: (t:domain-name whole-packet)) ] + (srv priority weight port target)))) + (else (bit-string->bytes rdata)))) + +;; RRType RData -> Bitstring +;; Encode RData according to the RRType. +(define (encode-rdata type rdata) + (case type + ((cname mb md mf mg mr ns ptr) (encode-domain-name rdata)) + ((hinfo) (bit-string ((hinfo-cpu rdata) :: (t:pascal-string)) + ((hinfo-os rdata) :: (t:pascal-string)))) + ((minfo) (bit-string ((minfo-rmailbx rdata) :: (t:domain-name)) + ((minfo-emailbx rdata) :: (t:domain-name)))) + ((mx) (bit-string ((mx-preference rdata) :: bits 16) + ((mx-exchange rdata) :: (t:domain-name)))) + ((null) rdata) + ((soa) (bit-string ((soa-mname rdata) :: (t:domain-name)) + ((soa-rname rdata) :: (t:domain-name)) + ((soa-serial rdata) :: bits 32) + ((soa-refresh rdata) :: bits 32) + ((soa-retry rdata) :: bits 32) + ((soa-expire rdata) :: bits 32) + ((soa-minimum rdata) :: bits 32))) + ((txt) (bit-string (rdata :: (t:listof (t:pascal-string))))) + ((a) (match rdata ((vector a b c d) (bit-string a b c d)))) + ((aaaa) (bit-string ((list->bytes (vector->list rdata)) :: binary bits 128))) + ((wks) (match (wks-address rdata) + ((vector a b c d) + (bit-string a b c d (wks-protocol rdata) ((wks-bitmap rdata) :: binary))))) + ((srv) (bit-string ((srv-priority rdata) :: bits 16) + ((srv-weight rdata) :: bits 16) + ((srv-port rdata) :: bits 16) + ((srv-target rdata) :: (t:domain-name)))) + (else rdata))) diff --git a/mapping.rkt b/mapping.rkt new file mode 100644 index 0000000..5802654 --- /dev/null +++ b/mapping.rkt @@ -0,0 +1,52 @@ +#lang racket/base +;; Macros for defining weak and extensible mappings between sets of values + +(provide define-mapping) + +;; Internal. Extracts macro keywords from a list of arguments. +(define-syntax check-defaults + (syntax-rules () + ((_ fn bn fd bd #:forward-default new-fd rest ...) + (check-defaults fn bn new-fd bd rest ...)) + ((_ fn bn fd bd #:backward-default new-bd rest ...) + (check-defaults fn bn fd new-bd rest ...)) + ((_ fn bn fd bd (lhs rhs) ...) + (begin + (define (fn l) + (case l + ((lhs) 'rhs) ... + (else (fd l)))) + (define (bn r) + (case r + ((rhs) 'lhs) ... + (else (bd r)))))))) + +;; Symbol -> raised exn:fail:contract +;; Used by default to complain when no specific mapping is found. +;; The argument indicates to the user the direction of the mapping. +(define (die-with-mapping-name n) + (lambda (v) + (raise (exn:fail:contract + (format "~v: Mapping not found for ~v" n v) + (current-continuation-marks))))) + +;; (define-mapping +;; { #:forward-default }? +;; { #:backward-default }? +;; ( ) ...) +;; Defines two functions, forward-name and backward-name, which take +;; values from the left-hand-sides of the mappings given as "( +;; )" to the right-hand-sides and vice versa, respectively. +;; +;; If specified, the #:forward-default and #:backward-default exprs +;; should evaluate to a procedure of one argument which can be used +;; for fallback computation of the mapping or for error +;; reporting. They default to raising exn:fail:contract. +(define-syntax define-mapping + (syntax-rules () + ((_ forward-name backward-name rest ...) + (check-defaults forward-name + backward-name + (die-with-mapping-name 'forward-name) + (die-with-mapping-name 'backward-name) + rest ...)))) diff --git a/test-dns.rkt b/test-dns.rkt new file mode 100644 index 0000000..01c919b --- /dev/null +++ b/test-dns.rkt @@ -0,0 +1,249 @@ +#lang racket/base + +(require "api.rkt") +(require "codec.rkt") + +;; Wed Jun 29 16:33:58 2011 (4e0b8c36): UDP: localhost sent 28 bytes: +;; 00000000: 66 3A 01 00 00 01 00 00 : 00 00 00 00 06 67 6F 6F f:...........goo +;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 FF 00 01 gle.com..... +;; 0000001C: + +(define (q-google-in-any) + (bytes #x66 #x3A #x01 #x00 #x00 #x01 #x00 #x00 + #x00 #x00 #x00 #x00 #x06 #x67 #x6F #x6F + #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 + #x00 #xFF #x00 #x01)) + +;; Wed Jun 29 16:33:58 2011 (4e0b8c36): UDP: dslrouter.westell.com sent 494 bytes: +;; 00000000: 66 3A 81 80 00 01 00 0F : 00 00 00 07 06 67 6F 6F f:...........goo +;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 FF 00 01 C0 0C 00 10 gle.com......... +;; 00000020: 00 01 00 00 0C 2F 00 52 : 51 76 3D 73 70 66 31 20 ...../.RQv=spf1 +;; 00000030: 69 6E 63 6C 75 64 65 3A : 5F 6E 65 74 62 6C 6F 63 include:_netbloc +;; 00000040: 6B 73 2E 67 6F 6F 67 6C : 65 2E 63 6F 6D 20 69 70 ks.google.com ip +;; 00000050: 34 3A 32 31 36 2E 37 33 : 2E 39 33 2E 37 30 2F 33 4:216.73.93.70/3 +;; 00000060: 31 20 69 70 34 3A 32 31 : 36 2E 37 33 2E 39 33 2E 1 ip4:216.73.93. +;; 00000070: 37 32 2F 33 31 20 7E 61 : 6C 6C C0 0C 00 01 00 01 72/31 ~all...... +;; 00000080: 00 00 01 1D 00 04 4A 7D : E2 92 C0 0C 00 01 00 01 ......J}........ +;; 00000090: 00 00 01 1D 00 04 4A 7D : E2 94 C0 0C 00 01 00 01 ......J}........ +;; 000000A0: 00 00 01 1D 00 04 4A 7D : E2 91 C0 0C 00 01 00 01 ......J}........ +;; 000000B0: 00 00 01 1D 00 04 4A 7D : E2 93 C0 0C 00 01 00 01 ......J}........ +;; 000000C0: 00 00 01 1D 00 04 4A 7D : E2 90 C0 0C 00 02 00 01 ......J}........ +;; 000000D0: 00 03 A5 1D 00 06 03 6E : 73 32 C0 0C C0 0C 00 02 .......ns2...... +;; 000000E0: 00 01 00 03 A5 1D 00 06 : 03 6E 73 33 C0 0C C0 0C .........ns3.... +;; 000000F0: 00 02 00 01 00 03 A5 1D : 00 06 03 6E 73 31 C0 0C ...........ns1.. +;; 00000100: C0 0C 00 02 00 01 00 03 : A5 1D 00 06 03 6E 73 34 .............ns4 +;; 00000110: C0 0C C0 0C 00 0F 00 01 : 00 00 00 2A 00 11 00 14 ...........*.... +;; 00000120: 04 61 6C 74 31 05 61 73 : 70 6D 78 01 6C C0 0C C0 .alt1.aspmx.l... +;; 00000130: 0C 00 0F 00 01 00 00 00 : 2A 00 09 00 1E 04 61 6C ........*.....al +;; 00000140: 74 32 C1 25 C0 0C 00 0F : 00 01 00 00 00 2A 00 04 t2.%.........*.. +;; 00000150: 00 0A C1 25 C0 0C 00 0F : 00 01 00 00 00 2A 00 09 ...%.........*.. +;; 00000160: 00 28 04 61 6C 74 33 C1 : 25 C0 0C 00 0F 00 01 00 .(.alt3.%....... +;; 00000170: 00 00 2A 00 09 00 32 04 : 61 6C 74 34 C1 25 C0 E8 ..*...2.alt4.%.. +;; 00000180: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 24 0A C0 FA ............$... +;; 00000190: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 20 0A C1 0C ............ ... +;; 000001A0: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 26 0A C0 D6 ............&... +;; 000001B0: 00 01 00 01 00 03 A2 CF : 00 04 D8 EF 22 0A C1 3D ............"..= +;; 000001C0: 00 01 00 01 00 00 00 F0 : 00 04 4A 7D 27 1B C1 25 ..........J}'..% +;; 000001D0: 00 01 00 01 00 00 00 F6 : 00 04 4A 7D 73 1B C1 20 ..........J}s.. +;; 000001E0: 00 01 00 01 00 00 00 21 : 00 04 4A 7D 4D 1B .......!..J}M. +;; 000001EE: + +(define (a-google-in-any) + (bytes + #x66 #x3A #x81 #x80 #x00 #x01 #x00 #x0F #x00 #x00 #x00 #x07 #x06 #x67 #x6F #x6F + #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #xFF #x00 #x01 #xC0 #x0C #x00 #x10 + #x00 #x01 #x00 #x00 #x0C #x2F #x00 #x52 #x51 #x76 #x3D #x73 #x70 #x66 #x31 #x20 + #x69 #x6E #x63 #x6C #x75 #x64 #x65 #x3A #x5F #x6E #x65 #x74 #x62 #x6C #x6F #x63 + #x6B #x73 #x2E #x67 #x6F #x6F #x67 #x6C #x65 #x2E #x63 #x6F #x6D #x20 #x69 #x70 + #x34 #x3A #x32 #x31 #x36 #x2E #x37 #x33 #x2E #x39 #x33 #x2E #x37 #x30 #x2F #x33 + #x31 #x20 #x69 #x70 #x34 #x3A #x32 #x31 #x36 #x2E #x37 #x33 #x2E #x39 #x33 #x2E + #x37 #x32 #x2F #x33 #x31 #x20 #x7E #x61 #x6C #x6C #xC0 #x0C #x00 #x01 #x00 #x01 + #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x92 #xC0 #x0C #x00 #x01 #x00 #x01 + #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x94 #xC0 #x0C #x00 #x01 #x00 #x01 + #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x91 #xC0 #x0C #x00 #x01 #x00 #x01 + #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x93 #xC0 #x0C #x00 #x01 #x00 #x01 + #x00 #x00 #x01 #x1D #x00 #x04 #x4A #x7D #xE2 #x90 #xC0 #x0C #x00 #x02 #x00 #x01 + #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x32 #xC0 #x0C #xC0 #x0C #x00 #x02 + #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x33 #xC0 #x0C #xC0 #x0C + #x00 #x02 #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x31 #xC0 #x0C + #xC0 #x0C #x00 #x02 #x00 #x01 #x00 #x03 #xA5 #x1D #x00 #x06 #x03 #x6E #x73 #x34 + #xC0 #x0C #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x11 #x00 #x14 + #x04 #x61 #x6C #x74 #x31 #x05 #x61 #x73 #x70 #x6D #x78 #x01 #x6C #xC0 #x0C #xC0 + #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x09 #x00 #x1E #x04 #x61 #x6C + #x74 #x32 #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x04 + #x00 #x0A #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 #x00 #x00 #x2A #x00 #x09 + #x00 #x28 #x04 #x61 #x6C #x74 #x33 #xC1 #x25 #xC0 #x0C #x00 #x0F #x00 #x01 #x00 + #x00 #x00 #x2A #x00 #x09 #x00 #x32 #x04 #x61 #x6C #x74 #x34 #xC1 #x25 #xC0 #xE8 + #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x24 #x0A #xC0 #xFA + #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x20 #x0A #xC1 #x0C + #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x26 #x0A #xC0 #xD6 + #x00 #x01 #x00 #x01 #x00 #x03 #xA2 #xCF #x00 #x04 #xD8 #xEF #x22 #x0A #xC1 #x3D + #x00 #x01 #x00 #x01 #x00 #x00 #x00 #xF0 #x00 #x04 #x4A #x7D #x27 #x1B #xC1 #x25 + #x00 #x01 #x00 #x01 #x00 #x00 #x00 #xF6 #x00 #x04 #x4A #x7D #x73 #x1B #xC1 #x20 + #x00 #x01 #x00 #x01 #x00 #x00 #x00 #x21 #x00 #x04 #x4A #x7D #x4D #x1B)) + +(require racket/pretty) +(pretty-print (packet->dns-message (q-google-in-any))) +(pretty-print (packet->dns-message (a-google-in-any))) + +(pretty-print (dns-message->packet (packet->dns-message (a-google-in-any)))) + +;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: localhost sent 28 bytes: +;; 00000000: 47 16 01 00 00 01 00 00 : 00 00 00 00 06 67 6F 6F G............goo +;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 1C 00 01 gle.com..... +;; 0000001C: +;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: pass through succeeded +;; Wed Jun 29 20:59:17 2011 (4e0bca65): UDP: google-public-dns-a.google.com sent 78 bytes: +;; 00000000: 47 16 81 80 00 01 00 00 : 00 01 00 00 06 67 6F 6F G............goo +;; 00000010: 67 6C 65 03 63 6F 6D 00 : 00 1C 00 01 C0 0C 00 06 gle.com......... +;; 00000020: 00 01 00 00 02 52 00 26 : 03 6E 73 31 C0 0C 09 64 .....R.&.ns1...d +;; 00000030: 6E 73 2D 61 64 6D 69 6E : C0 0C 00 16 33 23 00 00 ns-admin....3#.. +;; 00000040: 1C 20 00 00 07 08 00 12 : 75 00 00 00 01 2C . ......u...., +;; 0000004E: + +(pretty-print + (packet->dns-message + (bytes + #x47 #x16 #x01 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x06 #x67 #x6F #x6F + #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01))) + +(pretty-print + (packet->dns-message + (bytes + #x47 #x16 #x81 #x80 #x00 #x01 #x00 #x00 #x00 #x01 #x00 #x00 #x06 #x67 #x6F #x6F + #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01 #xC0 #x0C #x00 #x06 + #x00 #x01 #x00 #x00 #x02 #x52 #x00 #x26 #x03 #x6E #x73 #x31 #xC0 #x0C #x09 #x64 + #x6E #x73 #x2D #x61 #x64 #x6D #x69 #x6E #xC0 #x0C #x00 #x16 #x33 #x23 #x00 #x00 + #x1C #x20 #x00 #x00 #x07 #x08 #x00 #x12 #x75 #x00 #x00 #x00 #x01 #x2C))) + +;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: localhost sent 32 bytes: +;; 00000000: 12 70 01 00 00 01 00 00 : 00 00 00 00 03 77 77 77 .p...........www +;; 00000010: 06 67 6F 6F 67 6C 65 03 : 63 6F 6D 00 00 1C 00 01 .google.com..... +;; 00000020: +;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: pass through succeeded +;; Wed Jun 29 21:05:03 2011 (4e0bcbbf): UDP: ns1.google.com sent 52 bytes: +;; 00000000: 12 70 85 00 00 01 00 01 : 00 00 00 00 03 77 77 77 .p...........www +;; 00000010: 06 67 6F 6F 67 6C 65 03 : 63 6F 6D 00 00 1C 00 01 .google.com..... +;; 00000020: C0 0C 00 05 00 01 00 09 : 3A 80 00 08 03 77 77 77 ........:....www +;; 00000030: 01 6C C0 10 : .l.. +;; 00000034: + +(pretty-print + (packet->dns-message + (bytes + #x12 #x70 #x01 #x00 #x00 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x77 #x77 #x77 + #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01))) + +(pretty-print + (packet->dns-message + (bytes + #x12 #x70 #x85 #x00 #x00 #x01 #x00 #x01 #x00 #x00 #x00 #x00 #x03 #x77 #x77 #x77 + #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 #x01 + #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x08 #x03 #x77 #x77 #x77 + #x01 #x6C #xC0 #x10))) + +;; Wed Jun 29 21:07:46 2011 (4e0bcc62): UDP: ns1.google.com sent 82 bytes: +;; 00000000: 23 79 85 00 00 01 00 02 : 00 00 00 00 04 69 70 76 #y...........ipv +;; 00000010: 36 06 67 6F 6F 67 6C 65 : 03 63 6F 6D 00 00 1C 00 6.google.com.... +;; 00000020: 01 C0 0C 00 05 00 01 00 : 09 3A 80 00 09 04 69 70 .........:....ip +;; 00000030: 76 36 01 6C C0 11 C0 2D : 00 1C 00 01 00 00 01 2C v6.l...-......., +;; 00000040: 00 10 20 01 48 60 80 0F : 00 00 00 00 00 00 00 00 .. .H`.......... +;; 00000050: 00 68 : .h +;; 00000052: + +(pretty-print + (packet->dns-message + (bytes + #x23 #x79 #x85 #x00 #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x00 #x04 #x69 #x70 #x76 + #x36 #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 + #x01 #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x09 #x04 #x69 #x70 + #x76 #x36 #x01 #x6C #xC0 #x11 #xC0 #x2D #x00 #x1C #x00 #x01 #x00 #x00 #x01 #x2C + #x00 #x10 #x20 #x01 #x48 #x60 #x80 #x0F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x68))) + +(pretty-print + (dns-message->packet + (packet->dns-message + (bytes + #x23 #x79 #x85 #x00 #x00 #x01 #x00 #x02 #x00 #x00 #x00 #x00 #x04 #x69 #x70 #x76 + #x36 #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x1C #x00 + #x01 #xC0 #x0C #x00 #x05 #x00 #x01 #x00 #x09 #x3A #x80 #x00 #x09 #x04 #x69 #x70 + #x76 #x36 #x01 #x6C #xC0 #x11 #xC0 #x2D #x00 #x1C #x00 #x01 #x00 #x00 #x01 #x2C + #x00 #x10 #x20 #x01 #x48 #x60 #x80 #x0F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x68)))) + +;; Thu Jun 30 15:12:45 2011 (4e0ccaad): UDP: asgard.ccs.neu.edu sent 486 bytes: +;; 00000000: 13 CA 81 80 00 01 00 05 : 00 04 00 09 0C 5F 78 6D ............._xm +;; 00000010: 70 70 2D 73 65 72 76 65 : 72 04 5F 74 63 70 06 67 pp-server._tcp.g +;; 00000020: 6F 6F 67 6C 65 03 63 6F : 6D 00 00 21 00 01 C0 0C oogle.com..!.... +;; 00000030: 00 21 00 01 00 00 03 72 : 00 21 00 14 00 00 14 95 .!.....r.!...... +;; 00000040: 0C 78 6D 70 70 2D 73 65 : 72 76 65 72 34 01 6C 06 .xmpp-server4.l. +;; 00000050: 67 6F 6F 67 6C 65 03 63 : 6F 6D 00 C0 0C 00 21 00 google.com....!. +;; 00000060: 01 00 00 03 72 00 20 00 : 05 00 00 14 95 0B 78 6D ....r. .......xm +;; 00000070: 70 70 2D 73 65 72 76 65 : 72 01 6C 06 67 6F 6F 67 pp-server.l.goog +;; 00000080: 6C 65 03 63 6F 6D 00 C0 : 0C 00 21 00 01 00 00 03 le.com....!..... +;; 00000090: 72 00 21 00 14 00 00 14 : 95 0C 78 6D 70 70 2D 73 r.!.......xmpp-s +;; 000000A0: 65 72 76 65 72 31 01 6C : 06 67 6F 6F 67 6C 65 03 erver1.l.google. +;; 000000B0: 63 6F 6D 00 C0 0C 00 21 : 00 01 00 00 03 72 00 21 com....!.....r.! +;; 000000C0: 00 14 00 00 14 95 0C 78 : 6D 70 70 2D 73 65 72 76 .......xmpp-serv +;; 000000D0: 65 72 32 01 6C 06 67 6F : 6F 67 6C 65 03 63 6F 6D er2.l.google.com +;; 000000E0: 00 C0 0C 00 21 00 01 00 : 00 03 72 00 21 00 14 00 ....!.....r.!... +;; 000000F0: 00 14 95 0C 78 6D 70 70 : 2D 73 65 72 76 65 72 33 ....xmpp-server3 +;; 00000100: 01 6C 06 67 6F 6F 67 6C : 65 03 63 6F 6D 00 C1 02 .l.google.com... +;; 00000110: 00 02 00 01 00 01 54 24 : 00 06 03 6E 73 33 C1 02 ......T$...ns3.. +;; 00000120: C1 02 00 02 00 01 00 01 : 54 24 00 06 03 6E 73 34 ........T$...ns4 +;; 00000130: C1 02 C1 02 00 02 00 01 : 00 01 54 24 00 06 03 6E ..........T$...n +;; 00000140: 73 32 C1 02 C1 02 00 02 : 00 01 00 01 54 24 00 06 s2..........T$.. +;; 00000150: 03 6E 73 31 C1 02 C0 6D : 00 01 00 01 00 00 01 1A .ns1...m........ +;; 00000160: 00 04 4A 7D 99 7D C0 99 : 00 01 00 01 00 00 06 F6 ..J}.}.......... +;; 00000170: 00 04 4A 7D 35 7D C0 C6 : 00 01 00 01 00 00 06 F6 ..J}5}.......... +;; 00000180: 00 04 4A 7D 2F 7D C0 F3 : 00 01 00 01 00 00 06 F6 ..J}/}.......... +;; 00000190: 00 04 4A 7D 2D 7D C0 40 : 00 01 00 01 00 00 06 F6 ..J}-}.@........ +;; 000001A0: 00 04 4A 7D 2D 7D C1 50 : 00 01 00 01 00 00 0A B1 ..J}-}.P........ +;; 000001B0: 00 04 D8 EF 20 0A C1 3E : 00 01 00 01 00 00 0A B1 .... ..>........ +;; 000001C0: 00 04 D8 EF 22 0A C1 1A : 00 01 00 01 00 00 0A B1 ...."........... +;; 000001D0: 00 04 D8 EF 24 0A C1 2C : 00 01 00 01 00 00 0A B1 ....$..,........ +;; 000001E0: 00 04 D8 EF 26 0A : ....&. +;; 000001E6: + +;; ANSWER SECTION: +;;_xmpp-server._tcp.google.com. 900 IN SRV 5 0 5269 xmpp-server.l.google.com. +;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server1.l.google.com. +;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server2.l.google.com. +;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server3.l.google.com. +;;_xmpp-server._tcp.google.com. 900 IN SRV 20 0 5269 xmpp-server4.l.google.com. + +(pretty-print + (packet->dns-message + (bytes + #x13 #xCA #x81 #x80 #x00 #x01 #x00 #x05 #x00 #x04 #x00 #x09 #x0C #x5F #x78 #x6D + #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x04 #x5F #x74 #x63 #x70 #x06 #x67 + #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #x00 #x21 #x00 #x01 #xC0 #x0C + #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 #x00 #x14 #x00 #x00 #x14 #x95 + #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x34 #x01 #x6C #x06 + #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 + #x01 #x00 #x00 #x03 #x72 #x00 #x20 #x00 #x05 #x00 #x00 #x14 #x95 #x0B #x78 #x6D + #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x01 #x6C #x06 #x67 #x6F #x6F #x67 + #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 + #x72 #x00 #x21 #x00 #x14 #x00 #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 + #x65 #x72 #x76 #x65 #x72 #x31 #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 + #x63 #x6F #x6D #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 + #x00 #x14 #x00 #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 + #x65 #x72 #x32 #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D + #x00 #xC0 #x0C #x00 #x21 #x00 #x01 #x00 #x00 #x03 #x72 #x00 #x21 #x00 #x14 #x00 + #x00 #x14 #x95 #x0C #x78 #x6D #x70 #x70 #x2D #x73 #x65 #x72 #x76 #x65 #x72 #x33 + #x01 #x6C #x06 #x67 #x6F #x6F #x67 #x6C #x65 #x03 #x63 #x6F #x6D #x00 #xC1 #x02 + #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E #x73 #x33 #xC1 #x02 + #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E #x73 #x34 + #xC1 #x02 #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 #x03 #x6E + #x73 #x32 #xC1 #x02 #xC1 #x02 #x00 #x02 #x00 #x01 #x00 #x01 #x54 #x24 #x00 #x06 + #x03 #x6E #x73 #x31 #xC1 #x02 #xC0 #x6D #x00 #x01 #x00 #x01 #x00 #x00 #x01 #x1A + #x00 #x04 #x4A #x7D #x99 #x7D #xC0 #x99 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6 + #x00 #x04 #x4A #x7D #x35 #x7D #xC0 #xC6 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6 + #x00 #x04 #x4A #x7D #x2F #x7D #xC0 #xF3 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6 + #x00 #x04 #x4A #x7D #x2D #x7D #xC0 #x40 #x00 #x01 #x00 #x01 #x00 #x00 #x06 #xF6 + #x00 #x04 #x4A #x7D #x2D #x7D #xC1 #x50 #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1 + #x00 #x04 #xD8 #xEF #x20 #x0A #xC1 #x3E #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1 + #x00 #x04 #xD8 #xEF #x22 #x0A #xC1 #x1A #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1 + #x00 #x04 #xD8 #xEF #x24 #x0A #xC1 #x2C #x00 #x01 #x00 #x01 #x00 #x00 #x0A #xB1 + #x00 #x04 #xD8 #xEF #x26 #x0A))) diff --git a/test-mapping.rkt b/test-mapping.rkt new file mode 100644 index 0000000..fe4a478 --- /dev/null +++ b/test-mapping.rkt @@ -0,0 +1,26 @@ +#lang racket/base +;; Tests for mapping.rkt. + +(require "mapping.rkt") +(require rackunit) + +(define-mapping a->b b->a + (a b)) + +(check-equal? (a->b 'a) 'b) +(check-equal? (b->a 'b) 'a) +(check-exn exn:fail:contract? (lambda () (a->b 123))) +(check-exn exn:fail:contract? (lambda () (a->b 'b))) +(check-exn exn:fail:contract? (lambda () (b->a 123))) +(check-exn exn:fail:contract? (lambda () (b->a 'a))) + +(define-mapping c->d d->c + #:forward-default (lambda (x) 'default-d) + #:backward-default (lambda (x) 'default-c) + (c 123) + (e 234)) + +(check-equal? (c->d 'c) 123) +(check-equal? (d->c 234) 'e) +(check-equal? (c->d 'other) 'default-d) +(check-equal? (d->c '235) 'default-c)