2013-05-10 20:38:25 +00:00
|
|
|
#lang typed/racket/base
|
|
|
|
;; DNS wire-protocol codec.
|
2013-05-21 16:14:05 +00:00
|
|
|
;;
|
|
|
|
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
|
|
|
|
;;;
|
|
|
|
;;; This file is part of marketplace-dns.
|
|
|
|
;;;
|
|
|
|
;;; marketplace-dns is free software: you can redistribute it and/or
|
|
|
|
;;; modify it under the terms of the GNU General Public License as
|
|
|
|
;;; published by the Free Software Foundation, either version 3 of the
|
|
|
|
;;; License, or (at your option) any later version.
|
|
|
|
;;;
|
|
|
|
;;; marketplace-dns is distributed in the hope that it will be useful,
|
|
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
|
;;; General Public License for more details.
|
|
|
|
;;;
|
|
|
|
;;; You should have received a copy of the GNU General Public License
|
|
|
|
;;; along with marketplace-dns. If not, see
|
|
|
|
;;; <http://www.gnu.org/licenses/>.
|
2013-05-10 20:38:25 +00:00
|
|
|
|
|
|
|
(provide Opcode
|
|
|
|
ResponseCode
|
|
|
|
value->query-opcode query-opcode->value
|
|
|
|
value->query-response-code query-response-code->value
|
|
|
|
|
|
|
|
DNSMessage
|
|
|
|
Direction
|
|
|
|
Authoritativeness
|
|
|
|
Truncatedness
|
|
|
|
RecursionDesired
|
|
|
|
RecursionAvailable
|
|
|
|
(struct-out dns-message)
|
|
|
|
|
|
|
|
packet->dns-message
|
|
|
|
dns-message->packet
|
|
|
|
|
|
|
|
max-ttl
|
|
|
|
|
|
|
|
;; For the use of zonedb's save/load routines, etc.
|
|
|
|
t:rr)
|
|
|
|
|
|
|
|
(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-type Opcode (U 'query 'iquery 'status Nonnegative-Integer))
|
|
|
|
(: value->query-opcode : Nonnegative-Integer -> Opcode)
|
|
|
|
(: query-opcode->value : Opcode -> Nonnegative-Integer)
|
|
|
|
(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-type ResponseCode (U 'no-error 'format-error 'server-failure
|
|
|
|
'name-error 'not-implemented 'refused
|
|
|
|
Nonnegative-Integer))
|
|
|
|
(: value->query-response-code : Nonnegative-Integer -> ResponseCode)
|
|
|
|
(: query-response-code->value : ResponseCode -> Nonnegative-Integer)
|
|
|
|
(define-mapping value->query-response-code query-response-code->value
|
|
|
|
(0 no-error)
|
|
|
|
(1 format-error)
|
|
|
|
(2 server-failure)
|
|
|
|
(3 name-error) ;; most frequently known on the internet as NXDOMAIN.
|
|
|
|
(4 not-implemented)
|
|
|
|
(5 refused))
|
|
|
|
|
|
|
|
;; A DNSMessage is a
|
|
|
|
;; (dns-message Uint16 Direction Opcode Authoritativeness
|
|
|
|
;; Truncatedness RecursionDesired RecursionAvailable ResponseCode
|
|
|
|
;; ListOf<Question> ListOf<RR> ListOf<RR> ListOf<RR>).
|
|
|
|
;;
|
|
|
|
;; Interpreted as either a DNS request or reply, depending on the
|
|
|
|
;; Direction.
|
|
|
|
(struct: dns-message ([id : Nonnegative-Integer]
|
|
|
|
[direction : Direction]
|
|
|
|
[opcode : Opcode]
|
|
|
|
[authoritative : Authoritativeness]
|
|
|
|
[truncated : Truncatedness]
|
|
|
|
[recursion-desired : RecursionDesired]
|
|
|
|
[recursion-available : RecursionAvailable]
|
|
|
|
[response-code : ResponseCode]
|
|
|
|
[questions : (Listof Question)]
|
|
|
|
[answers : (Listof RR)]
|
|
|
|
[authorities : (Listof RR)]
|
|
|
|
[additional : (Listof RR)])
|
|
|
|
#:transparent)
|
|
|
|
(define-type DNSMessage dns-message)
|
|
|
|
(define-type Direction (U 'request 'response))
|
|
|
|
(define-type Authoritativeness (U 'non-authoritative 'authoritative))
|
|
|
|
(define-type Truncatedness (U 'not-truncated 'truncated))
|
|
|
|
(define-type RecursionDesired (U 'no-recursion-desired 'recursion-desired))
|
|
|
|
(define-type RecursionAvailable (U 'no-recursion-available 'recursion-available))
|
|
|
|
|
|
|
|
;; 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 Integer len bits 32)) ] vals))
|
|
|
|
;; (bit-string (vals :: (t:ntimes Integer bits 32)))
|
|
|
|
(define-syntax t:ntimes
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ #t input0 ks kf Type times-to-repeat option ...)
|
|
|
|
(let ()
|
|
|
|
;; A simple loop without multiple-values or #f is much cleaner
|
|
|
|
;; here, but I can't find a way of expressing the types
|
|
|
|
;; required while making that work. This way, we avoid needing
|
|
|
|
;; to mention the type of the result of calls to ks.
|
|
|
|
(: loop : Integer (Listof Type) BitString -> (Values (Option (Listof Type)) BitString))
|
|
|
|
(define (loop count acc input)
|
|
|
|
(cond
|
|
|
|
((positive? count) (bit-string-case input
|
|
|
|
([ (v :: option ...) (rest :: binary) ]
|
|
|
|
(loop (- count 1) (cons v acc) rest))
|
|
|
|
(else
|
|
|
|
(values #f input))))
|
|
|
|
(else (values (reverse acc) input))))
|
|
|
|
(let-values (((vs rest) (loop times-to-repeat '() input0)))
|
|
|
|
(if vs
|
|
|
|
(ks vs rest)
|
|
|
|
(kf)))))
|
|
|
|
((_ #f val Type option ...)
|
|
|
|
(t:listof #f val Type 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 Integer bits 32)) ] vals))
|
|
|
|
;; (bit-string (vals :: (t:listof Integer bits 32)))
|
|
|
|
(define-syntax t:listof
|
|
|
|
(syntax-rules ()
|
|
|
|
((_ #t input0 ks kf Type option ...)
|
|
|
|
;; The loop is unrolled once here to let Typed Racket propagate
|
|
|
|
;; the type of v0 into the type of acc in the loop. When not
|
|
|
|
;; unrolled, it gives acc type (Listof Any).
|
|
|
|
;; TODO: come up with some other way of doing this that avoids the duplication.
|
|
|
|
(bit-string-case input0
|
|
|
|
([ (v0 :: option ...) (input1 :: binary) ]
|
|
|
|
(let loop ((acc (list v0))
|
|
|
|
(input input1))
|
|
|
|
(bit-string-case input
|
|
|
|
([ (v :: option ...) (rest :: binary) ]
|
|
|
|
(loop (cons v acc) rest))
|
|
|
|
([]
|
|
|
|
(ks (reverse acc) #""))
|
|
|
|
(else
|
|
|
|
(kf)))))
|
|
|
|
([]
|
|
|
|
(ks '() #""))
|
|
|
|
(else
|
|
|
|
(kf))))
|
|
|
|
((_ #f vs Type option ...)
|
|
|
|
(let: loop : BitString ((vs : (Listof Type) 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
|
|
|
|
;; 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
|
|
|
|
;; +---------------------+
|
|
|
|
;; </rfc1035>
|
|
|
|
|
|
|
|
;; <rfc1035>
|
|
|
|
;; 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 |
|
|
|
|
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|
|
|
|
;; </rfc1035>
|
|
|
|
|
|
|
|
(: packet->dns-message : BitString -> 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)
|
|
|
|
|
|
|
|
;; 16 bits of flags, opcode, and response-code:
|
|
|
|
(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 Question qdcount (t:question packet)))
|
|
|
|
(a-section :: (t:ntimes RR ancount (t:rr packet)))
|
|
|
|
(auth-section :: (t:ntimes RR nscount (t:rr packet)))
|
|
|
|
(additional-section :: (t:ntimes RR 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))))
|
|
|
|
|
|
|
|
(: dns-message->packet : 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 Question (t:question)))
|
|
|
|
((dns-message-answers m) :: (t:ntimes RR (t:rr)))
|
|
|
|
((dns-message-authorities m) :: (t:ntimes RR (t:rr)))
|
|
|
|
((dns-message-additional m) :: (t:ntimes RR (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 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;
|
|
|
|
;; 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 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))))
|
|
|
|
|
|
|
|
(: encode-domain-name : DomainName -> BitString)
|
|
|
|
(define (encode-domain-name name)
|
|
|
|
(define labels (domain-labels name))
|
|
|
|
(bit-string (labels :: (t:listof Bytes (t:pascal-string "Label" 64)))
|
|
|
|
(0 :: integer bytes 1))) ;; end of list of labels!
|
|
|
|
|
|
|
|
(: parse-domain-name :
|
|
|
|
BitString BitString (Listof Natural) -> (Values (Listof Bytes) BitString))
|
|
|
|
;; 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 input ks kf)
|
|
|
|
(bit-string-case input
|
|
|
|
([ len (body :: binary bytes len) (rest :: binary) ]
|
|
|
|
(ks (bit-string->bytes body) rest))
|
|
|
|
(else (kf))))
|
|
|
|
((_ #f val)
|
|
|
|
(t:pascal-string #f val "Character-string" 256))
|
|
|
|
((_ #f val string-kind length-limit)
|
|
|
|
(let: ([s : Bytes val])
|
|
|
|
(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,
|
|
|
|
;; 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 |
|
|
|
|
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|
|
|
|
;; </rfc1035>
|
|
|
|
|
|
|
|
;; 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 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 val)
|
|
|
|
(let: ([q : Question val])
|
|
|
|
(bit-string ((question-repr-name q) :: (t:domain-name))
|
|
|
|
((qtype->value (question-repr-type q)) :: bits 16)
|
|
|
|
((qclass->value (question-repr-class q)) :: bits 16))))))
|
|
|
|
|
|
|
|
;; <rfc1035>
|
|
|
|
;; 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 /
|
|
|
|
;; / /
|
|
|
|
;; +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|
|
|
|
;; </rfc1035>
|
|
|
|
|
|
|
|
;; 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 input ks kf whole-packet0)
|
|
|
|
(let ((whole-packet whole-packet0))
|
|
|
|
(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
|
|
|
|
(value->class class)
|
|
|
|
ttl
|
|
|
|
(decode-rdata whole-packet type rdata))
|
|
|
|
tail)))
|
|
|
|
(else (kf)))))
|
|
|
|
((_ #f val)
|
|
|
|
(let: ([rr : RR val])
|
|
|
|
(let ((encoded-rdata (encode-rdata (rr-rdata rr))))
|
|
|
|
(bit-string ((rr-name rr) :: (t:domain-name))
|
|
|
|
((type->value (rdata-type (rr-rdata rr))) :: bits 16)
|
|
|
|
((class->value (rr-class rr)) :: bits 16)
|
|
|
|
((rr-ttl rr) :: bits 32)
|
|
|
|
((quotient (bit-string-length encoded-rdata) 8) :: bits 16)
|
|
|
|
(encoded-rdata :: binary)))))))
|
|
|
|
|
|
|
|
(: decode-rdata : BitString RRType BitString -> 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)) ]
|
|
|
|
(rdata-domain type name))))
|
|
|
|
((hinfo) (bit-string-case rdata
|
|
|
|
([ (cpu :: (t:pascal-string)) (os :: (t:pascal-string)) ]
|
|
|
|
(rdata-hinfo type cpu os))))
|
|
|
|
((minfo) (bit-string-case rdata
|
|
|
|
([ (rmailbx :: (t:domain-name whole-packet))
|
|
|
|
(emailbx :: (t:domain-name whole-packet)) ]
|
|
|
|
(rdata-minfo type rmailbx emailbx))))
|
|
|
|
((mx) (bit-string-case rdata
|
|
|
|
([ (preference :: bits 16)
|
|
|
|
(exchange :: (t:domain-name whole-packet)) ]
|
|
|
|
(rdata-mx type preference exchange))))
|
|
|
|
((null) (rdata-raw type (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) ]
|
|
|
|
(rdata-soa type mname rname serial refresh retry expire minimum))))
|
|
|
|
((txt) (bit-string-case rdata
|
|
|
|
([ (strs :: (t:listof Bytes (t:pascal-string))) ]
|
|
|
|
(rdata-txt type strs))))
|
|
|
|
((a) (bit-string-case rdata
|
|
|
|
([ a b c d ]
|
|
|
|
(rdata-ipv4 type (vector a b c d)))))
|
|
|
|
((aaaa) (bit-string-case rdata
|
|
|
|
([ a b c d e f g h i j k l m n o p ]
|
|
|
|
(rdata-ipv6 type (vector a b c d e f g h i j k l m n o p)))))
|
|
|
|
((wks) (bit-string-case rdata
|
|
|
|
([ a b c d protocol (bitmap :: binary) ]
|
|
|
|
(rdata-wks type (vector a b c d) protocol (bit-string->bytes bitmap)))))
|
|
|
|
((srv) (bit-string-case rdata
|
|
|
|
([ (priority :: bits 16)
|
|
|
|
(weight :: bits 16)
|
|
|
|
(port :: bits 16)
|
|
|
|
(target :: (t:domain-name whole-packet)) ]
|
|
|
|
(rdata-srv type priority weight port target))))
|
|
|
|
(else (rdata-raw type (bit-string->bytes rdata)))))
|
|
|
|
|
|
|
|
(: encode-rdata : RData -> BitString)
|
|
|
|
;; Encode RData according to its RRType.
|
|
|
|
(define (encode-rdata rdata)
|
|
|
|
(match rdata
|
|
|
|
[(rdata-domain _ name) (encode-domain-name name)]
|
|
|
|
[(rdata-hinfo _ cpu os) (bit-string (cpu :: (t:pascal-string))
|
|
|
|
(os :: (t:pascal-string)))]
|
|
|
|
[(rdata-minfo _ rmailbx emailbx) (bit-string (rmailbx :: (t:domain-name))
|
|
|
|
(emailbx :: (t:domain-name)))]
|
|
|
|
[(rdata-mx _ preference exchange) (bit-string (preference :: bits 16)
|
|
|
|
(exchange :: (t:domain-name)))]
|
|
|
|
[(rdata-soa _ mname rname serial refresh retry expire minimum)
|
|
|
|
(bit-string (mname :: (t:domain-name))
|
|
|
|
(rname :: (t:domain-name))
|
|
|
|
(serial :: bits 32)
|
|
|
|
(refresh :: bits 32)
|
|
|
|
(retry :: bits 32)
|
|
|
|
(expire :: bits 32)
|
|
|
|
(minimum :: bits 32))]
|
|
|
|
[(rdata-txt _ strings) (bit-string (strings :: (t:listof Bytes (t:pascal-string))))]
|
|
|
|
[(rdata-ipv4 _ (vector a b c d)) (bit-string a b c d)]
|
|
|
|
[(rdata-ipv6 _ aaaa) (bit-string ((list->bytes (vector->list aaaa)) :: binary bits 128))]
|
|
|
|
[(rdata-wks _ (vector a b c d) protocol bitmap)
|
|
|
|
(bit-string a b c d protocol (bitmap :: binary))]
|
|
|
|
[(rdata-srv _ priority weight port target)
|
|
|
|
(bit-string (priority :: bits 16)
|
|
|
|
(weight :: bits 16)
|
|
|
|
(port :: bits 16)
|
|
|
|
(target :: (t:domain-name)))]
|
|
|
|
[(rdata-raw _ bs) bs]))
|
|
|
|
|
|
|
|
;; UInt32
|
|
|
|
(: max-ttl : Nonnegative-Integer)
|
|
|
|
(define max-ttl #xffffffff)
|