#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)