marketplace-dns-2014/api.rkt

#lang typed/racket/base
;; Definitions for use in the API to the functionality of the library.
;;
;;; 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 DomainName
	 (except-out (struct-out domain) domain)
	 (rename-out [make-domain domain])
	 domain-root?
	 domain-parent

	 IPv4
	 IPv6

	 (struct-out question-repr)
	 Question question question?
	 QuestionPattern question-pattern question-pattern?

	 question-cyclic?
	 question-too-glueless?
	 question-restarted?
	 restart-question
	 cname-question
	 ns-question

	 (struct-out answered-question-repr)
	 AnsweredQuestion answered-question answered-question?
	 AnsweredQuestionPattern answered-question-pattern answered-question-pattern?
	 (struct-out rr)
	 RR

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

	 RData
	 (struct-out rdata)
	 (struct-out rdata-domain)
	 (struct-out rdata-ipv4)
	 (struct-out rdata-ipv6)
	 (struct-out rdata-hinfo)
	 (struct-out rdata-minfo)
	 (struct-out rdata-mx)
	 (struct-out rdata-soa)
	 (struct-out rdata-wks)
	 (struct-out rdata-srv)
	 (struct-out rdata-txt)
	 (struct-out rdata-raw)
	 rdata-type-pred

	 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 marketplace)
(require marketplace/struct-map)
(require marketplace/support/pseudo-substruct)

;; 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: (TName TType TClass TContext)
	 question-repr
	 ([name : TName] [type : TType] [class : TClass] [context : TContext])
	 #:transparent)
(pseudo-substruct: (question-repr DomainName QueryType QueryClass QuestionContext)
		   Question question question?)
(pseudo-substruct: (question-repr (U Wild DomainName)
				  (U Wild QueryType)
				  (U Wild QueryClass)
				  (U Wild QuestionContext))
		   QuestionPattern question-pattern question-pattern?)

;; 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]) #:transparent)
(struct: cname-subq subquestion () #:transparent)
(struct: ns-subq subquestion () #:transparent)
(define-type QuestionContext (U subquestion cname-subq ns-subq False 'restart))

;; An AnsweredQuestion is an (answered-question Question
;; Maybe<CompleteAnswer>).
(struct: (TQ TA) answered-question-repr ([q : TQ] [a : TA]) #:transparent)
(pseudo-substruct: (answered-question-repr Question (Option CompleteAnswer))
		   AnsweredQuestion answered-question answered-question?)
(pseudo-substruct: (answered-question-repr (U Wild Question) (U Wild (Option CompleteAnswer)))
		   AnsweredQuestionPattern answered-question-pattern answered-question-pattern?)

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

;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
;; representing a resource record.
(struct: rr ([name : DomainName]
	     [class : RRClass]
	     [ttl : Nonnegative-Integer]
	     [rdata : RData])
	 #:transparent)
(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: rdata ([type : RRType]) #:transparent)
(struct: rdata-domain rdata ([name : DomainName]) #:transparent)
(struct: rdata-ipv4 rdata ([address : IPv4]) #:transparent)
(struct: rdata-ipv6 rdata ([address : IPv6]) #:transparent)
(struct: rdata-hinfo rdata ([cpu : Bytes] [os : Bytes]) #:transparent)
(struct: rdata-minfo rdata ([rmailbx : DomainName] [emailbx : DomainName]) #:transparent)
(struct: rdata-mx rdata ([preference : Nonnegative-Integer] [exchange : DomainName]) #:transparent)
(struct: rdata-soa rdata ([mname : DomainName]
			  [rname : DomainName]
			  [serial : Nonnegative-Integer]
			  [refresh : Nonnegative-Integer]
			  [retry : Nonnegative-Integer]
			  [expire : Nonnegative-Integer]
			  [minimum : Nonnegative-Integer]) #:transparent)
(struct: rdata-wks rdata ([address : IPv4] [protocol : Byte] [bitmap : Bytes]) #:transparent)
(struct: rdata-srv rdata ([priority : Nonnegative-Integer]
			  [weight : Nonnegative-Integer]
			  [port : Nonnegative-Integer]
			  [target : DomainName]) #:transparent)
(struct: rdata-txt rdata ([strings : (Listof Bytes)]) #:transparent)
(struct: rdata-raw rdata ([body : Bytes]) #:transparent)
(define-type RData rdata)

(: rdata-type-pred : RRType -> (RData -> Boolean))
(define ((rdata-type-pred t) d)
  (eq? (rdata-type d) t))

;; 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))
		  (data (map rr-rdata records)))
	     (if (set-member? seen name)
		 (loop (cdr names) ips seen)
		 (let ((a-data (filter rdata-ipv4? (filter (rdata-type-pred 'a) data)))
		       (cname-data (filter rdata-domain? (filter (rdata-type-pred 'cname) data))))
		   (loop (append (map rdata-domain-name cname-data) (cdr names))
			 (set-union ips (list->set (map rdata-ipv4-address a-data)))
			 (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-repr 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 ?