racket-dns-2012/network-query.rkt

#lang racket/base

(require racket/set)
(require racket/match)
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require "os-big-bang.rkt")
(require "os-udp.rkt")
(require "os-dns.rkt")
(require "os-timer.rkt")

(provide network-query/addresses)

;; DJB's rules for handling DNS responses. Some of these are handled
;; here (specifically, rules 2 through 5, in the action of
;; incorporate-dns-reply), some are handled in resolver.rkt (rule
;; 1, in the action of answer-from-zone):

;; <blockquote>
;; When a cache receives a normal DNS response, it learns exactly one
;; of the following five pieces of information:
;;
;; 1. ``The query was not answered because the query name is an
;; alias. I need to change the query name and try again.'' This
;; applies if the answer section of the response contains a CNAME
;; record for the query name and CNAME does not match the query type.
;;
;; 2. ``The query name has no records answering the query, and is also
;; guaranteed to have no records of any other type.'' This applies if
;; the response code is NXDOMAIN and #1 doesn't apply. The amount of
;; time that this information can be cached depends on the contents of
;; the SOA record in the authority section of the response, if there
;; is one.
;;
;; 3. ``The query name has one or more records answering the query.''
;; This applies if the answer section of the response contains one or
;; more records under the query name matching the query type, and #1
;; doesn't apply, and #2 doesn't apply.
;;
;; 4. ``The query was not answered because the server does not have
;; the answer. I need to contact other servers.'' This applies if the
;; authority section of the response contains NS records, and the
;; authority section of the response does not contain SOA records, and
;; #1 doesn't apply, and #2 doesn't apply, and #3 doesn't apply. The
;; ``other servers'' are named in the NS records in the authority
;; section.
;;
;; 5. ``The query name has no records answering the query, but it may
;; have records of another type.'' This applies if #1 doesn't apply,
;; and #2 doesn't apply, and #3 doesn't apply, and #4 doesn't
;; apply. The amount of time that this information can be cached
;; depends on the contents of the SOA record in the authority section,
;; if there is one.
;;
;; This procedure requires an incredible amount of bug-prone parsing
;; for a very small amount of information. The underlying problem is
;; that DNS was designed to declare information in a human-oriented
;; format, rather than to support crucial operations in the simplest
;; possible way.
;; </blockquote>

(define first-timeout 3) ;; seconds

;; seconds -> Maybe<seconds>
(define (next-timeout timeout)
  (case timeout
    ((3) 11)
    ((11) 45)
    ((45) #f)))

;; IPv4 -> String
(define (ip->host-name ip-address)
  (match-define (vector a b c d) ip-address)
  (format "~a.~a.~a.~a" a b c d))

(define (make-dns-query-message q)
  (dns-message (random 65536)
	       'request
	       'query
	       'non-authoritative
	       'not-truncated
	       'no-recursion-desired
	       'no-recursion-available
	       'no-error
	       (list q)
	       '()
	       '()
	       '()))

;; filter-dns-reply : DNSMessage DomainName -> (or Maybe<Set<RR>> 'no-answer)
;;
;; Filters RRs from the answer, authorities, and additional sections
;; of the passed-in `message`, returning the set of RRs surviving the
;; filter. RRs are only accepted if their `rr-name` falls in the
;; bailiwick of the given `zone-origin`. All of this only happens if
;; the passed-in message's `dns-message-response-code` is `'no-error`:
;; if it's `'name-error`, then `#f` is returned, and if it's any other
;; code, `'no-answer` is returned.
(define (filter-dns-reply message zone-origin)
  (case (dns-message-response-code message)
    [(no-error) 
     (list->set
      (filter (lambda (claim-rr) (in-bailiwick? (rr-name claim-rr) zone-origin))
	      (append (dns-message-answers message)
		      (dns-message-authorities message)
		      (dns-message-additional message))))]
    [(name-error) #f]
    [else 'no-answer]))

;; network-query/addresses :
;;   UdpAddress Question DomainName ListOf<IPv4>
;;     (Maybe<Set<RR>> -> ListOf<Action>) -> ListOf<Action>
;;
;; Repeatedly uses `network-query/addresses/timeout` to try asking the
;; whole of `server-ips` the question `q`, starting with a timeout of
;; `first-timeout` seconds and increasing each time
;; `network-query/addresses/timeout` returns `'no-answer` up to a
;; give-up timeout limit.
(define (network-query/addresses s q zone-origin server-ips k)
  (let try-with-timeout ((timeout first-timeout))
    (if timeout
	(network-query/addresses/timeout s q zone-origin server-ips timeout
	 (lambda (result)
	   (if (eq? result 'no-answer)
	       (try-with-timeout (next-timeout timeout))
	       (k result))))
	(k (set)))))

;; network-query/addresses/timeout :
;;   UdpAddress Question DomainName ListOf<IPv4> Seconds
;;     ((or Maybe<Set<RR>> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
;;
;; Sends the question to each of the servers whose addresses are given
;; in `server-ips` using `network-query/address/timeout`, one at a
;; time, in order, trying the next in the list only if `'no-answer`
;; results from the most recent communication attempt. If and when the
;; list is exhausted, `'no-answer` is returned.
(define (network-query/addresses/timeout s q zone-origin server-ips timeout k)
  ;; TODO: randomize ordering of servers in list.
  (let search ((remaining-ips server-ips))
    (if (null? remaining-ips)
	(k 'no-answer)
	(network-query/address/timeout s q zone-origin (car remaining-ips) timeout
	 (lambda (result)
	   (if (eq? result 'no-answer)
	       (search (cdr remaining-ips))
	       (k result)))))))

;; network-query/address/timeout :
;;   UdpAddress Question DomainName IPv4 Seconds
;;     ((or Maybe<Set<RR>> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
;;
;; Sends the question to the server address `server-ip` given. Waits
;; `timeout` seconds for an answer: if one arrives, it is filtered and
;; the result is returned to the caller. If the timeout expires before
;; a reply is received, or some error result is received from the
;; server, `'no-answer` is returned to the caller.
(define (network-query/address/timeout s q zone-origin server-ip timeout k)
  (define server-host-name (ip->host-name server-ip))
  (define server-port 53)
  (define query (make-dns-query-message q))
  (define req (dns-request query
			   s
			   (udp-address server-host-name server-port)))
  (define subscription-id (list s (dns-message-id query)))
  (define start-time (current-inexact-milliseconds))
  (list (send-message req)
	(send-message (set-timer subscription-id (* timeout 1000) #t))
	(subscribe subscription-id
	 (message-handlers w
	  [(timer-expired (== subscription-id) _)
	   (write `(Timed out ,q to ,zone-origin ,server-ip after ,timeout seconds)) (newline)
	   (transition w
		       (unsubscribe subscription-id)
		       (k 'no-answer))]
	  [(dns-reply reply-message source (== s))
	   ;; TODO: maybe receive only specifically from the queried IP address?
	   (write `(,q --> ,(dns-message-answers reply-message) from ,server-ip in
		       ,(inexact->exact (round (- (current-inexact-milliseconds) start-time)))
		       ms)) (newline)
	   (if (not (= (dns-message-id reply-message) (dns-message-id query)))
	       w
	       (transition w
			   (unsubscribe subscription-id)
			   (k (filter-dns-reply reply-message zone-origin))))]))))