#lang racket/base
;;
;;; 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/>.

(require racket/pretty)

(require racket/set)
(require racket/match)
(require racket/list)
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")

(provide (struct-out partial-answer)
	 (struct-out referral)
	 resolve-from-zone)

;; Rules:
;;
;;  - If the DB already has an answer, return it.
;;
;;  - Otherwise, find the leafmost NS record in the DB for the
;;    requested name.
;;
;;  - Query that service. Augment the DB with the answers received, if
;;    any. Loop back to the beginning, remembering that we've tried
;;    the specific service we just interacted with so we don't try it
;;    again.
;;
;;  - Eventually, the DB will have either been augmented with an
;;    answer, or we will have run out of untried nameservers to ask.
;;
;;  - Authoritative NXDOMAINs ('name-error) mean we get to stop
;;    looking.
;;
;;  - Resolve CNAMEs on the way. Remember which names we've been
;;    resolving in response to any given query, to avoid
;;    loops. Perhaps limit the length of the chain to avoid
;;    DoS. (TODO)
;;
;;  - Only performs recursive service if so requested.
;;
;;  - See RFC 1035 section 7.1.

;; An Answer is one of
;; -- a PartialAnswer (some CNAMEs need expanding),
;; -- a CompleteAnswer (a complete answer ready to send),
;; -- #f (the domain name does not exist in the CompiledZone given),
;; -- a Referral (a referral to some other nameserver).

;; A PartialAnswer is a (partial-answer CompleteAnswer ListOf<DomainName>)
;; A collection of relevant RRs together with some CNAMEs that need expanding.
(struct partial-answer (base cnames) #:transparent)

;; A Referral is a (referral DomainName Set<RR> Set<RR>)
(struct referral (zone-origin nameserver-rrs additional) #:transparent)

;; (: answer-from-zone : Question CompiledZone (Option RR) -> Answer)
;; An answer of #f here does NOT indicate a missing domain-name
;; (name-error/NXDOMAIN), but instead indicates that there are no
;; records matching the query in the database given. It's up to the
;; caller to decide what to do about that.
(define (answer-from-zone q zone start-of-authority)
  (match-define (question name qtype qclass _) q)
  (define rrset (or (zone-ref zone name) (set)))
  (define filtered-rrs (filter-rrs rrset qtype qclass))
  (define cnames (filter-by-type rrset 'cname)) ;; TODO: filter by class too??
  (define answer-set (set-union cnames filtered-rrs))
  (define base (complete-answer answer-set
				(if (and start-of-authority
					 (in-bailiwick? name (rr-name start-of-authority)))
				    (set start-of-authority)
				    (set))
				(set)))
  (cond
   [(set-empty? answer-set) ;; No matching records or domain absent (deliberately ambiguous)
    #f]
   [(or (eq? qtype 'cname) (set-empty? cnames)) ;; Either asking for CNAMEs, or no CNAMEs to expand
    base]
   [else ;; Kick off the algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a
    (partial-answer base (set-map cnames rr-rdata-domain-name))]))

;; (: closest-nameservers : DomainName CompiledZone -> (Setof RR))
(define (closest-nameservers name zone)
  (let search ((name name))
    (cond
     ((not name)
      ;; We've walked up the tree past the root. Give up.
      (set))
     ((zone-ref zone name) =>
      ;; There's an entry for this suffix of the original name. Check
      ;; to see if it has an NS record indicating a subzone.
      (lambda (rrset)
	(define ns-rrset (filter-by-type rrset 'ns))
	(if (set-empty? ns-rrset)
	    (search (domain-parent name)) ;; no NS records for this suffix. Keep looking.
	    ns-rrset)))
     (else
      ;; Remove a label and keep looking.
      (search (domain-parent name))))))

;; (: closest-untried-nameservers : Question CompiledZone (Setof DomainName) -> (Setof RR))
;; Returns a set of NS RRs in an arbitrary order.
(define (closest-untried-nameservers q zone nameservers-tried)
  (define name (question-name q))
  (define ns-rrset (closest-nameservers name zone))
  (list->set
   (for/list ([rr ns-rrset] #:when (not (set-member? nameservers-tried (rr-rdata-domain-name rr))))
     rr)))

;; (: empty-answer : Question CompiledZone (Option RR) -> (Option CompleteAnswer))
(define (empty-answer q zone start-of-authority)
  (if (and start-of-authority ;; we are authoritative for something
	   (in-bailiwick? (question-name q) (rr-name start-of-authority))
	   ;; ^ for this in particular
	   (not (zone-includes-name? zone (question-name q))))
           ;; ^ there are no RRs at all for this q
      ;; NXDOMAIN/name-error: we definitely know there are no RRs at all for this q.
      #f
      ;; A normal no-answers packet otherwise.
      (empty-complete-answer)))

;; (: additional-section/a : CompiledZone (Listof DomainName) -> (Setof RR))
;; Implements the "additional section" rules from RFC 1035 (and the
;; rules for IPv6 from RFC 3596). Provides A and AAAA records for
;; names mentioned in the "names" list that have entries in "zone".
(define (additional-section/a zone names)
  ;; RFC 3596 (section 3) requires that we process AAAA here as well
  ;; as A.
  (foldl (lambda (name section)
	   (set-union section
		      (set-filter (lambda (rr)
				    (and (memv (rdata-type (rr-rdata rr)) '(a aaaa))
					 (eqv? (rr-class rr) 'in)))
				  (or (zone-ref zone name) (set)))))
	 (set)
	 names))

;; (: resolve-from-zone : Question CompiledZone (Option RR) (Setof DomainName) -> Answer)
(define (resolve-from-zone q zone start-of-authority nameservers-tried)
  (or (answer-from-zone q zone start-of-authority)
      (let ((best-nameservers (closest-untried-nameservers q zone nameservers-tried)))
	(if (set-empty? best-nameservers)
	    (empty-answer q zone start-of-authority)
	    (let ((zone-origin (rr-name (car (set->list best-nameservers))))) ;; any entry will do
	      (referral zone-origin
			best-nameservers
			(additional-section/a zone (set-map best-nameservers
							    rr-rdata-domain-name))))))))