marketplace-dns-2014/codec.rkt

511 lines
20 KiB
Racket

#lang racket/base
;; DNS wire-protocol codec.
;;
;;; 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/>.
(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
max-ttl
;; For the use of zonedb's save/load routines, etc.
t:rr)
(require "api.rkt")
(require "mapping.rkt")
(require racket/match)
(require 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.
;; (: 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.
;; (: 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
direction
opcode
authoritative
truncated
recursion-desired
recursion-available
response-code
questions
answers
authorities
additional)
#:transparent)
;; (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 ((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
;; 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))
(:: bits 3) ;; previously, had to be zero; now, Z, AD and CD respectively. See RFC 2535.
(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 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 val])
(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:
;;
;; 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 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)