racket-dns-2012/api.rkt

#lang typed/racket/base
;; Definitions for use in the API to the functionality of the library.

(provide DomainName
	 (except-out (struct-out domain) domain)
	 (rename-out [make-domain domain])
	 domain-root?
	 domain-parent

	 IPv4
	 IPv6

	 Question
	 (struct-out question)
	 question-cyclic?
	 question-too-glueless?
	 question-restarted?
	 restart-question
	 cname-question
	 ns-question

	 AnsweredQuestion
	 RR
	 (struct-out answered-question)
	 (struct-out rr)

	 CompleteAnswer
	 (struct-out complete-answer)
	 empty-complete-answer
	 merge-answers
	 extract-addresses

	 RData
	 (struct-out hinfo)
	 (struct-out minfo)
	 (struct-out mx)
	 (struct-out soa)
	 (struct-out wks)
	 (struct-out srv)
	 rr-rdata/cast

	 RRType
	 QueryType
	 RRClass
	 QueryClass
	 type->value value->type
	 qtype->value value->qtype
	 class->value value->class
	 qclass->value value->qclass)

(require "mapping.rkt")
(require racket/set)
(require racket/match)
(require racket-typed-matrix/struct-map)

;; A DomainName is a (domain ListOf<Bytes>), representing a domain
;; name. The head of the list is the leftmost label; for example,
;; www.google.com is represented as '(#"www" #"google" #"com").
(require/typed "api-untyped.rkt"
	       [#:struct domain ([labels : (Listof Bytes)]
				 [downcased-labels : (Listof Bytes)])])
(define-type DomainName domain)

;; 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).
(define-type IPv4 (Vector Byte Byte Byte Byte))

;; 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).
(define-type IPv6 (Vector Byte Byte Byte Byte
			  Byte Byte Byte Byte
			  Byte Byte Byte Byte
			  Byte Byte Byte Byte))

;; A Question is a (question DomainName QueryType QueryClass
;; QuestionContext), representing a DNS question: "What are the RRs
;; for the given name, type and class?" as well as a possible parent
;; question that the answer to this question is to contribute to the
;; answer to.
(struct: question
	 ([name : DomainName] [type : QueryType] [class : QueryClass] [context : QuestionContext])
	 #:prefab)
(define-type Question question)

;; A QuestionContext is one of
;; -- (cname-subq Question), resulting from the expansion of a CNAME
;; -- (ns-subq Question), resulting from a network referral
;; -- #f, an original question from a remote peer
;; -- 'restart, a restarted question.
;;
;; The context is needed to break cycles in the DNS database. If the
;; context chain ends in 'restart, then the question results from an
;; excessively-glueless subquestion not represented here, and should
;; *not* in turn be considered for gluelessness-restarting: this is
;; needed to avoid a different kind of infinite loop.
(struct: subquestion ([parent : Question]) #:prefab)
(struct: cname-subq subquestion () #:prefab)
(struct: ns-subq subquestion () #:prefab)
(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart))

;; An AnsweredQuestion is an (answered-question Question
;; Maybe<CompleteAnswer>).
(struct: answered-question ([q : Question] [a : (Option CompleteAnswer)]) #:prefab)
(define-type AnsweredQuestion answered-question)

;; A CompleteAnswer is a (complete-answer Set<RR> Set<RR> Set<RR>)
(struct: complete-answer
	 ([rrs : (Setof RR)] [authorities : (Setof RR)] [additional : (Setof RR)])
	 #:prefab)
(define-type CompleteAnswer complete-answer)

;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
;; representing a resource record.
(struct: rr ([name : DomainName]
	     [type : RRType]
	     [class : RRClass]
	     [ttl : Nonnegative-Integer]
	     [rdata : RData])
	 #:prefab)
(define-type RR rr)

;; An RData is one of
;; - a DomainName, for CNAME, MB, MD, MF, MG, MR, NS and PTR records
;; - an IPv4, an "A" record
;; - an IPv6, an "AAAA" record
;; - (hinfo Bytes Bytes), 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 ListOf<Bytes>, a txt 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 : Bytes] [os : Bytes]) #:prefab)
(struct: minfo ([rmailbx : DomainName] [emailbx : DomainName]) #:prefab)
(struct: mx ([preference : Nonnegative-Integer] [exchange : DomainName]) #:prefab)
(struct: soa ([mname : DomainName]
	      [rname : DomainName]
	      [serial : Nonnegative-Integer]
	      [refresh : Nonnegative-Integer]
	      [retry : Nonnegative-Integer]
	      [expire : Nonnegative-Integer]
	      [minimum : Nonnegative-Integer]) #:prefab)
(struct: wks ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:prefab)
(struct: srv ([priority : Nonnegative-Integer]
	      [weight : Nonnegative-Integer]
	      [port : Nonnegative-Integer]
	      [target : DomainName]) #:prefab)
(define-type RData (U DomainName IPv4 IPv6 hinfo minfo mx soa wks srv (Listof Bytes) Bytes))

(define-syntax-rule (rr-rdata/cast Type)
  (lambda: ([rr : RR]) (cast (rr-rdata rr) Type)))

;; 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-type RRType (U 'a 'ns 'md 'mf 'cname 'soa 'mb 'mg
		       'mr 'null 'wks 'ptr 'hinfo 'minfo 'mx 'txt
		       'aaaa 'srv
		       Nonnegative-Integer))
(: type->value : RRType -> Nonnegative-Integer)
(: value->type : Nonnegative-Integer -> RRType)
(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-type QueryType (U RRType 'axfr 'mailb 'maila '*))
(: qtype->value : QueryType -> Nonnegative-Integer)
(: value->qtype : Nonnegative-Integer -> QueryType)
(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-type RRClass (U 'in 'cs 'ch 'hs Nonnegative-Integer))
(: class->value : RRClass -> Nonnegative-Integer)
(: value->class : Nonnegative-Integer -> RRClass)
(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-type QueryClass (U RRClass '*))
(: qclass->value : QueryClass -> Nonnegative-Integer)
(: value->qclass : Nonnegative-Integer -> QueryClass)
(define-mapping qclass->value value->qclass
  #:forward-default class->value
  #:backward-default value->class
  (* 255))

;; ListOf<Bytes> -> ListOf<Bytes>
;; Converts the 7-bit ASCII bytes in the argument to lower-case
;; equivalents. Used to normalize case for domain-name comparisons.
(: downcase-labels : (Listof Bytes) -> (Listof Bytes))
(define (downcase-labels labels)
  (for/list ([label labels])
    (define b (make-bytes (bytes-length label)))
    (for ([i (bytes-length label)])
      (define v (bytes-ref label i))
      (bytes-set! b i (if (<= 65 v 90) (+ 32 v) v)))
    b))

;; ListOf<Bytes> -> DomainName
;; Replacement constructor for domain structs. Automatically downcases
;; labels appropriately.
(: make-domain : (Listof Bytes) -> DomainName)
(define (make-domain labels)
  (domain labels (downcase-labels labels)))

(: domain-root? : DomainName -> Boolean)
(define (domain-root? d)
  (null? (domain-labels d)))

(: domain-parent : DomainName -> (Option DomainName))
(define (domain-parent d)
  (and (pair? (domain-labels d))
       (domain (cdr (domain-labels d))
	       (cdr (domain-downcased-labels d)))))

(: empty-complete-answer : -> CompleteAnswer)
(define (empty-complete-answer)
  (complete-answer (set) (set) (set)))

(: merge-answers : CompleteAnswer CompleteAnswer -> CompleteAnswer)
(define (merge-answers a1 a2)
  (match-define (complete-answer n1 u1 d1) a1)
  (match-define (complete-answer n2 u2 d2) a2)
  (complete-answer (set-union n1 n2)
		   (set-union u1 u2)
		   (set-union d1 d2)))

(: extract-addresses : DomainName (Option CompleteAnswer) -> (Setof IPv4))
(define (extract-addresses name ans)
  (match ans
    [#f ;; name-error/NXDOMAIN, so definitely no addresses.
     (set)]
    [(complete-answer ns us ds)
     (define rrs (set->list (set-union ns us ds)))
     (let loop ((names (list name))
		(ips ((inst set IPv4)))
		(seen ((inst set DomainName))))
       (if (null? names)
	   ips
	   (let* ((name (car names))
		  (records (filter (lambda: ([rr : RR]) (equal? name (rr-name rr))) rrs)))
	     (if (set-member? seen name)
		 (loop (cdr names) ips seen)
		 (let ((a-records (filter (lambda: ([rr : RR]) (equal? 'a (rr-type rr))) records))
		       (cname-records
			(filter (lambda: ([rr : RR]) (equal? 'cname (rr-type rr))) records)))
		   (loop (append (map (rr-rdata/cast DomainName) cname-records) (cdr names))
			 (set-union ips (list->set (map (rr-rdata/cast IPv4) a-records)))
			 (set-add seen name)))))))]))

;; Question -> Boolean
;; #t iff this question is being asked in order to supply answers
;; contributing to a parent context that's trying to answer exactly
;; this question.
(: question-cyclic? : Question -> Boolean)
(define (question-cyclic? q)
  (match-define (question name type class parent) q)
  (let: search : Boolean ((ancestor : QuestionContext parent))
    (match ancestor
      [(subquestion (question (== name) (== type) (== class) _)) #t] ;; uh-oh! A cycle!
      [(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)] ;; recursive case
      [_ #f]))) ;; no further parents -> definitely not cyclic

;; Question -> Boolean
;; If we're looking up a nameserver's address, in order to look up a
;; nameserver's address, in order to answer some question, that came
;; from the outside world, then that's too glueless.  See
;; http://cr.yp.to/djbdns/notes.html in the sections "Gluelessness"
;; and "Expiring glue".
(: question-too-glueless? : Question -> Boolean)
(define (question-too-glueless? q)
  (define count
    (let: search : Integer ((q : Question q) (acc : Integer 0))
      (match-define (question _ _ _ parent) q)
      (cond
       [(ns-subq? parent) (search (subquestion-parent parent) (+ acc 1))]
       [(subquestion? parent) (search (subquestion-parent parent) acc)]
       [else acc])))
  (if (>= count 2)
      ;; We're (at least) at the right nesting level: now see if this
      ;; question was already the result of a restart. If so, we
      ;; grimly press on with it unchanged.
      (not (question-restarted? q))
      #f))

;; Question -> Boolean
;; #t iff this question is being asked in the context of some
;; excessively glueless subquestion.
(: question-restarted? : Question -> Boolean)
(define (question-restarted? q)
  (match-define (question name type class parent) q)
  (let search ((ancestor parent))
    (match ancestor
      [(subquestion (question _ _ _ ancestor-parent)) (search ancestor-parent)]
      ['restart #t]
      [_ #f])))

;; Question -> Question
;; Returns a question equivalent to q, but in a 'restart context, for
;; retracing from the roots in cases of excessive gluelessness.
(: restart-question : Question -> Question)
(define (restart-question q)
  (struct-copy question q [context 'restart]))

;; DomainName Question -> Question
;; Produces a new question with CNAME context.
(: cname-question : DomainName Question -> Question)
(define (cname-question name q)
  (match-define (question _ type class _) q)
  (question name type class (cname-subq q)))

;; DomainName Question -> Question
;; Produces a new question with NS context.
(: ns-question : DomainName Question -> Question)
(define (ns-question name q)
  (question name 'a 'in (ns-subq q))) ;; TODO: 'aaaa ?