2012-01-24 19:19:25 +00:00
|
|
|
#lang racket/base
|
2011-12-30 18:57:54 +00:00
|
|
|
|
|
|
|
(require racket/match)
|
2012-01-24 19:19:25 +00:00
|
|
|
(require racket/udp)
|
2011-12-30 18:57:54 +00:00
|
|
|
(require "api.rkt")
|
|
|
|
(require "codec.rkt")
|
|
|
|
(require "zonedb.rkt")
|
2012-01-25 18:50:49 +00:00
|
|
|
(require "os-big-bang.rkt")
|
|
|
|
(require "os-udp.rkt")
|
|
|
|
(require "os-dns.rkt")
|
2012-01-25 20:06:49 +00:00
|
|
|
(require "os-timer.rkt")
|
2011-12-30 18:57:54 +00:00
|
|
|
|
2012-01-24 19:19:25 +00:00
|
|
|
(provide network-query/addresses)
|
2011-12-30 18:57:54 +00:00
|
|
|
|
2011-12-30 19:50:10 +00:00
|
|
|
;; DJB's rules for handling DNS responses. Some of these are handled
|
|
|
|
;; here (specifically, rules 2 through 5, in the action of
|
2012-01-24 19:19:25 +00:00
|
|
|
;; incorporate-dns-reply), some are handled in resolver.rkt (rule
|
2011-12-30 19:50:10 +00:00
|
|
|
;; 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>
|
|
|
|
|
2011-12-30 18:57:54 +00:00
|
|
|
(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))
|
|
|
|
|
2012-01-25 18:50:49 +00:00
|
|
|
(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)
|
|
|
|
'()
|
|
|
|
'()
|
|
|
|
'()))
|
2011-12-30 18:57:54 +00:00
|
|
|
|
|
|
|
;; incorporate-dns-reply :
|
2012-01-25 22:45:53 +00:00
|
|
|
;; DNSMessage CompiledZone DomainName
|
2012-01-25 18:50:49 +00:00
|
|
|
;; -> (or Maybe<CompiledZone> 'no-answer)
|
2011-12-30 18:57:54 +00:00
|
|
|
;;
|
|
|
|
;; Incorporates RRs from the answer, authorities, and additional
|
|
|
|
;; sections of the passed-in `message` to the passed-in `zone`,
|
|
|
|
;; returning the augmented zone. RRs are only incorporated if their
|
2012-01-25 22:45:53 +00:00
|
|
|
;; `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 (incorporate-dns-reply message zone zone-origin)
|
2011-12-30 18:57:54 +00:00
|
|
|
(case (dns-message-response-code message)
|
|
|
|
[(no-error)
|
|
|
|
(foldl (lambda (claim-rr zone)
|
2012-01-25 22:45:53 +00:00
|
|
|
(if (in-bailiwick? (rr-name claim-rr) zone-origin)
|
2011-12-30 18:57:54 +00:00
|
|
|
(incorporate-rr claim-rr zone)
|
|
|
|
zone))
|
|
|
|
zone
|
|
|
|
(append (dns-message-answers message)
|
|
|
|
(dns-message-authorities message)
|
|
|
|
(dns-message-additional message)))]
|
|
|
|
[(name-error) #f]
|
2012-01-25 18:50:49 +00:00
|
|
|
[else 'no-answer]))
|
2011-12-30 18:57:54 +00:00
|
|
|
|
|
|
|
;; network-query/addresses :
|
2012-01-25 22:45:53 +00:00
|
|
|
;; UdpAddress Question CompiledZone DomainName ListOf<IPv4>
|
2012-01-25 18:50:49 +00:00
|
|
|
;; (Maybe<CompiledZone> -> ListOf<Action>) -> ListOf<Action>
|
2011-12-30 18:57:54 +00:00
|
|
|
;;
|
|
|
|
;; 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.
|
2012-01-25 22:45:53 +00:00
|
|
|
(define (network-query/addresses s q zone zone-origin server-ips k)
|
2012-01-25 18:50:49 +00:00
|
|
|
(let try-with-timeout ((timeout first-timeout))
|
2012-01-25 22:45:53 +00:00
|
|
|
(network-query/addresses/timeout s q zone zone-origin server-ips timeout
|
2012-01-25 18:50:49 +00:00
|
|
|
(lambda (result)
|
|
|
|
(if (eq? result 'no-answer)
|
|
|
|
(let ((new-timeout (next-timeout timeout)))
|
|
|
|
(if new-timeout
|
|
|
|
(try-with-timeout new-timeout)
|
|
|
|
(k zone)))
|
|
|
|
(k result))))))
|
2011-12-30 18:57:54 +00:00
|
|
|
|
|
|
|
;; network-query/addresses/timeout :
|
2012-01-25 22:45:53 +00:00
|
|
|
;; UdpAddress Question CompiledZone DomainName ListOf<IPv4> Seconds
|
2012-01-25 18:50:49 +00:00
|
|
|
;; ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
2011-12-30 18:57:54 +00:00
|
|
|
;;
|
|
|
|
;; 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.
|
2012-01-25 22:45:53 +00:00
|
|
|
(define (network-query/addresses/timeout s q zone zone-origin server-ips timeout k)
|
2011-12-30 18:57:54 +00:00
|
|
|
;; TODO: randomize ordering of servers in list.
|
|
|
|
(let search ((remaining-ips server-ips))
|
|
|
|
(if (null? remaining-ips)
|
2012-01-25 18:50:49 +00:00
|
|
|
(k 'no-answer)
|
2012-01-25 22:45:53 +00:00
|
|
|
(network-query/address/timeout s q zone zone-origin (car remaining-ips) timeout
|
2012-01-25 18:50:49 +00:00
|
|
|
(lambda (result)
|
|
|
|
(if (eq? result 'no-answer)
|
|
|
|
(search (cdr remaining-ips))
|
|
|
|
(k result)))))))
|
2012-01-24 19:19:25 +00:00
|
|
|
|
2011-12-30 18:57:54 +00:00
|
|
|
;; network-query/address/timeout :
|
2012-01-25 22:45:53 +00:00
|
|
|
;; UdpAddress Question CompiledZone DomainName IPv4 Seconds
|
2012-01-25 18:50:49 +00:00
|
|
|
;; ((or Maybe<CompiledZone> 'no-answer) -> ListOf<Action>) -> ListOf<Action>
|
2011-12-30 18:57:54 +00:00
|
|
|
;;
|
|
|
|
;; Sends the question to the server address `server-ip` given. Waits
|
|
|
|
;; `timeout` seconds for an answer: if one arrives, it is incorporated
|
|
|
|
;; into the passed-in `zone` (using `incorporate-dns-reply`), 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.
|
2012-01-25 22:45:53 +00:00
|
|
|
(define (network-query/address/timeout s q zone zone-origin server-ip timeout k)
|
2011-12-30 18:57:54 +00:00
|
|
|
(define server-host-name (ip->host-name server-ip))
|
|
|
|
(define server-port 53)
|
2012-01-25 18:50:49 +00:00
|
|
|
(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)))
|
2012-01-25 22:56:57 +00:00
|
|
|
(define start-time (current-inexact-milliseconds))
|
2012-01-25 18:50:49 +00:00
|
|
|
(list (send-message req)
|
2012-01-25 20:06:49 +00:00
|
|
|
(send-message (set-timer subscription-id (* timeout 1000) #t))
|
2012-01-25 18:50:49 +00:00
|
|
|
(subscribe subscription-id
|
2012-01-25 22:45:53 +00:00
|
|
|
(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?
|
2012-01-25 22:56:57 +00:00
|
|
|
(write `(,q --> ,(dns-message-answers reply-message) from ,server-ip in
|
|
|
|
,(inexact->exact (round (- (current-inexact-milliseconds) start-time)))
|
|
|
|
ms)) (newline)
|
2012-01-25 22:45:53 +00:00
|
|
|
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
|
|
|
w
|
|
|
|
(transition w
|
|
|
|
(unsubscribe subscription-id)
|
|
|
|
(k (incorporate-dns-reply reply-message zone zone-origin))))]))))
|