Move (and generalise) resolver logic from server into zonedb.rkt for reuse by proxy.
This commit is contained in:
parent
b62e7d8bf4
commit
faaa81b310
11
api.rkt
11
api.rkt
|
@ -2,6 +2,7 @@
|
||||||
;; Definitions for use in the API to the functionality of the library.
|
;; Definitions for use in the API to the functionality of the library.
|
||||||
|
|
||||||
(provide (struct-out question)
|
(provide (struct-out question)
|
||||||
|
(struct-out question-result)
|
||||||
(struct-out rr)
|
(struct-out rr)
|
||||||
|
|
||||||
(struct-out hinfo)
|
(struct-out hinfo)
|
||||||
|
@ -18,9 +19,6 @@
|
||||||
|
|
||||||
(require "mapping.rkt")
|
(require "mapping.rkt")
|
||||||
|
|
||||||
;; A QueryResponder is a (Question -> Either<ListOf<RR>, Failure>), a
|
|
||||||
;; function from DNS query to DNS response or failure.
|
|
||||||
|
|
||||||
;; A DomainName is a ListOf<Bytes>, representing a domain name. The
|
;; A DomainName is a ListOf<Bytes>, representing a domain name. The
|
||||||
;; head of the list is the leftmost label; for example, www.google.com
|
;; head of the list is the leftmost label; for example, www.google.com
|
||||||
;; is represented as '(#"www" #"google" #"com").
|
;; is represented as '(#"www" #"google" #"com").
|
||||||
|
@ -41,6 +39,13 @@
|
||||||
;; type and class?"
|
;; type and class?"
|
||||||
(struct question (name type class) #:transparent)
|
(struct question (name type class) #:transparent)
|
||||||
|
|
||||||
|
;; A QuestionResult is a (question-result Question CompiledZone
|
||||||
|
;; SetOf<RR> SetOf<RR> SetOf<RR>), representing the results of
|
||||||
|
;; answering a Question in the context of a given RR database,
|
||||||
|
;; possibly after recursively asking other servers for answers.
|
||||||
|
(struct question-result (question knowledge answers authorities additional)
|
||||||
|
#:transparent)
|
||||||
|
|
||||||
;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
|
;; An RR is a (rr DomainName RRType RRClass Uint32 RData),
|
||||||
;; representing a resource record.
|
;; representing a resource record.
|
||||||
(struct rr (name type class ttl rdata) #:transparent)
|
(struct rr (name type class ttl rdata) #:transparent)
|
||||||
|
|
260
proxy.rkt
260
proxy.rkt
|
@ -11,6 +11,9 @@
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
(require "zonedb.rkt")
|
(require "zonedb.rkt")
|
||||||
(require "dump-bytes.rkt")
|
(require "dump-bytes.rkt")
|
||||||
|
(require "simple-udp-service.rkt")
|
||||||
|
|
||||||
|
(require racket/pretty)
|
||||||
|
|
||||||
;; Instantiated with a collection of trusted roots to begin its
|
;; Instantiated with a collection of trusted roots to begin its
|
||||||
;; searches from. Performs recursive queries. Doesn't yet cache
|
;; searches from. Performs recursive queries. Doesn't yet cache
|
||||||
|
@ -75,171 +78,134 @@
|
||||||
;; format, rather than to support crucial operations in the simplest
|
;; format, rather than to support crucial operations in the simplest
|
||||||
;; possible way.
|
;; possible way.
|
||||||
|
|
||||||
(define (authoritativeness-for dn soa-rr)
|
;; An Address can be an (address String Uint16) or #f, where an
|
||||||
(if (in-bailiwick? dn (rr-name soa-rr))
|
;; address struct represents nonlocal UDP sockets, and #f represents
|
||||||
'authoritative
|
;; the local socket. This way, we don't need to know the IP or port of
|
||||||
'non-authoritative))
|
;; the local socket, and we can be "multihomed".
|
||||||
|
(struct address (host port) #:prefab) ;; a UDP IP/port-number combination
|
||||||
|
|
||||||
|
(struct bad-dns-packet (detail source target reason) #:prefab)
|
||||||
|
(struct world-message (body source target) #:prefab)
|
||||||
|
|
||||||
|
;; ServerState
|
||||||
|
(struct world (roots continuations) #:prefab)
|
||||||
|
|
||||||
;; start-proxy : UInt16 ListOf<RR> -> Void
|
;; start-proxy : UInt16 ListOf<RR> -> Void
|
||||||
;; Starts a proxy service that will answer questions received on the
|
;; Starts a proxy service that will answer questions received on the
|
||||||
;; given UDP port based on the NS RRs it is given.
|
;; given UDP port based on the NS RRs it is given.
|
||||||
(require racket/pretty)
|
|
||||||
(define (start-proxy port-number raw-roots)
|
(define (start-proxy port-number raw-roots)
|
||||||
;; Compile the table of roots
|
;; Compile the table of roots
|
||||||
(define roots (compile-zone-db raw-roots))
|
(define roots (compile-zone-db raw-roots))
|
||||||
(pretty-print roots)
|
(pretty-print roots)
|
||||||
|
|
||||||
;; Set up the socket
|
(define initial-world (world roots (make-immutable-hash)))
|
||||||
(define s (udp-open-socket #f #f))
|
|
||||||
(udp-bind! s #f port-number)
|
|
||||||
|
|
||||||
(define (service-loop)
|
(start-udp-service
|
||||||
(with-handlers ((exn:break? (lambda (e) (raise e)))
|
port-number
|
||||||
(exn? (lambda (e)
|
udp-packet->message
|
||||||
(display "Error in DNS proxy handler:") (newline)
|
outbound-message?
|
||||||
(write e)
|
message->udp-packet
|
||||||
(newline)
|
(message-handlers old-world
|
||||||
(newline))))
|
[(? bad-dns-packet? p)
|
||||||
(read-and-process-request))
|
(pretty-print p)
|
||||||
(service-loop))
|
(values '() old-world)]
|
||||||
|
[(? request-from-downstream? r)
|
||||||
|
(handle-request r old-world)]
|
||||||
|
[(? reply-from-upstream? r)
|
||||||
|
(handle-reply r old-world)])
|
||||||
|
(lambda (unhandled state)
|
||||||
|
(error 'dns-server "Unhandled packet ~v" unhandled))
|
||||||
|
initial-world
|
||||||
|
#:packet-size-limit 512))
|
||||||
|
|
||||||
(define (read-and-process-request)
|
(define (udp-packet->message packet)
|
||||||
(define buffer (make-bytes 512))
|
(match-define (udp-packet body host port) packet)
|
||||||
(define-values (packet-length source-hostname source-port)
|
(define a (address host port))
|
||||||
(udp-receive! s buffer))
|
(with-handlers ((exn? (lambda (e) (bad-dns-packet body a #f 'unparseable))))
|
||||||
|
(define message (packet->dns-message body))
|
||||||
|
(world-message message a #f)))
|
||||||
|
|
||||||
(define (send-error error-response-code)
|
(define (message->udp-packet m)
|
||||||
(bit-string-case buffer
|
(match-define (world-message body _ (address host port)) m)
|
||||||
([ (id :: bits 16) (:: binary) ]
|
(udp-packet (dns-message->packet body) host port))
|
||||||
(udp-send-to s source-hostname source-port
|
|
||||||
(dns-message->packet
|
|
||||||
(dns-message id 'response 'query
|
|
||||||
'non-authoritative 'not-truncated
|
|
||||||
'no-recursion-desired 'recursion-available
|
|
||||||
error-response-code '() '() '() '()))))
|
|
||||||
(else
|
|
||||||
;; We don't even have enough information in the packet to reply.
|
|
||||||
(void))))
|
|
||||||
|
|
||||||
(display "----------------------------------------") (newline)
|
(define (local-address? a)
|
||||||
(write (subbytes buffer 0 packet-length)) (newline)
|
(eq? a #f))
|
||||||
(dump-bytes! buffer packet-length)
|
|
||||||
(flush-output)
|
|
||||||
|
|
||||||
(define request-message
|
(define (remote-address? a)
|
||||||
(with-handlers ((exn? (lambda (e)
|
(address? a))
|
||||||
(send-error 'format-error)
|
|
||||||
(raise e))))
|
|
||||||
(packet->dns-message (subbytes buffer 0 packet-length))))
|
|
||||||
|
|
||||||
;;(write request-message) (newline)
|
(define (outbound-message? m)
|
||||||
|
(and (world-message? m)
|
||||||
|
(local-address? (world-message-source m))
|
||||||
|
(remote-address? (world-message-target m))))
|
||||||
|
|
||||||
(define (make-reply name send-name-error? answers authorities additional)
|
(define (inbound-message? m)
|
||||||
(dns-message (dns-message-id request-message)
|
(and (world-message? m)
|
||||||
'response
|
(remote-address? (world-message-source m))
|
||||||
'query
|
(local-address? (world-message-target m))))
|
||||||
(authoritativeness-for name soa-rr)
|
|
||||||
'not-truncated
|
|
||||||
(dns-message-recursion-desired request-message)
|
|
||||||
'recursion-available
|
|
||||||
(if send-name-error? 'name-error 'no-error)
|
|
||||||
(dns-message-questions request-message)
|
|
||||||
(set->list answers)
|
|
||||||
(set->list authorities)
|
|
||||||
(set->list additional)))
|
|
||||||
|
|
||||||
(define reply-packet
|
(define (request-from-downstream? m)
|
||||||
(with-handlers ((exn? (lambda (e)
|
(and (inbound-message? m)
|
||||||
(send-error 'server-failure)
|
(eq? (dns-message-direction (world-message-body m)) 'request)
|
||||||
(raise e))))
|
(eq? (dns-message-opcode (world-message-body m)) 'query)))
|
||||||
;; TODO: check opcode and direction in request
|
|
||||||
(define questions (dns-message-questions request-message))
|
|
||||||
(if (null? questions)
|
|
||||||
#f ;; No questions -> don't send any replies
|
|
||||||
(begin
|
|
||||||
;; TODO: what if there are multiple questions in one
|
|
||||||
;; request packet? Single reply, or multiple replies?
|
|
||||||
;; Process the additional questions, or ignore them?
|
|
||||||
;; djbdns looks like it handles exactly one question per
|
|
||||||
;; request, ignoring any excess...
|
|
||||||
(dns-message->packet (answer-question (car questions) make-reply))))))
|
|
||||||
|
|
||||||
;; TODO: Truncation
|
(define (reply-from-upstream? m)
|
||||||
(when reply-packet
|
(and (inbound-message? m)
|
||||||
(udp-send-to s source-hostname source-port reply-packet)))
|
(eq? (dns-message-direction (world-message-body m)) 'response)
|
||||||
|
(eq? (dns-message-opcode (world-message-body m)) 'query)))
|
||||||
|
|
||||||
(define (answer-question q make-reply)
|
(define (handle-request r old-world)
|
||||||
(let resolve ((name (question-name q)))
|
(match-define (world-message (struct* dns-message
|
||||||
;; Notice that we claim to be authoritative for our configured
|
([id query-id]
|
||||||
;; zone. If we ever answer name-error, that means there are no
|
[recursion-desired recursion-desired]
|
||||||
;; RRs *at all* for the queried name. If there are RRs for the
|
[questions questions]))
|
||||||
;; queried name, but they happen not to be the ones asked for,
|
request-source
|
||||||
;; name-error must *not* be returned: instead, a normal
|
request-target)
|
||||||
;; no-error reply is sent with an empty answer section.
|
r)
|
||||||
;;
|
|
||||||
;; If we wanted to support caching of negative replies, we'd
|
|
||||||
;; follow the guidelines in section 4.3.4 "Negative response
|
|
||||||
;; caching" of RFC1034, adding our zone SOA with an
|
|
||||||
;; appropriate TTL to the additional section of the reply.
|
|
||||||
;;
|
|
||||||
;; TODO: We support returning out-of-bailiwick records (glue)
|
|
||||||
;; here. Reexamine the rules for doing so.
|
|
||||||
(cond
|
|
||||||
((hash-ref zone name #f) =>
|
|
||||||
;; The full name matches in our zone database.
|
|
||||||
(lambda (rrset)
|
|
||||||
(define filtered-rrs (filter-rrs rrset (question-type q) (question-class q)))
|
|
||||||
(define cnames (filter-by-type rrset 'cname))
|
|
||||||
(define base-reply (make-reply name
|
|
||||||
#f
|
|
||||||
(set-union cnames filtered-rrs)
|
|
||||||
(set soa-rr)
|
|
||||||
(set)))
|
|
||||||
;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a.
|
|
||||||
(if (and (not (set-empty? cnames))
|
|
||||||
(not (eqv? (question-type q) 'cname)))
|
|
||||||
(foldl (lambda (cname-rr current-reply)
|
|
||||||
(merge-replies current-reply
|
|
||||||
(resolve (rr-rdata cname-rr))))
|
|
||||||
base-reply
|
|
||||||
(set->list cnames))
|
|
||||||
base-reply)))
|
|
||||||
((referral-for name soa-rr zone) =>
|
|
||||||
;; No full name match, but a referral to somewhere beneath our
|
|
||||||
;; SOA but within our zone.
|
|
||||||
(lambda (ns-rrset)
|
|
||||||
(make-reply name
|
|
||||||
#f
|
|
||||||
ns-rrset
|
|
||||||
(set soa-rr)
|
|
||||||
(additional-section/a zone (set-map ns-rrset rr-rdata)))))
|
|
||||||
(else
|
|
||||||
;; Neither a full name match nor a referral is
|
|
||||||
;; available. Answer name-error (NXDOMAIN) if the queried
|
|
||||||
;; name is in-bailiwick, or a normal no-error otherwise.
|
|
||||||
(make-reply name
|
|
||||||
(in-bailiwick? name (rr-name soa-rr))
|
|
||||||
(set)
|
|
||||||
(set)
|
|
||||||
(set))))))
|
|
||||||
|
|
||||||
(service-loop))
|
(let loop ((remaining-questions questions)
|
||||||
|
(outbound-messages '())
|
||||||
|
(w old-world)
|
||||||
|
(temporary-cache (world-roots old-world)))
|
||||||
|
(if (null? remaining-questions)
|
||||||
|
(values outbound-messages w)
|
||||||
|
(let ((q (car remaining-questions)))
|
||||||
|
(define-values (answer new-w new-cache) (answer-question q w temporary-cache))
|
||||||
|
(loop (cdr remaining-questions)
|
||||||
|
(if answer
|
||||||
|
(cons answer outbound-messages)
|
||||||
|
outbound-messages)
|
||||||
|
new-w
|
||||||
|
new-cache)))))
|
||||||
|
|
||||||
(start-server 5555
|
;; TODO: OMG this is a total toy proxy implementation. Pays attention
|
||||||
(rr '(#"example") 'soa 'in 30
|
;; to NONE of the sensible guidelines or even the rules for
|
||||||
(soa '(#"ns" #"example")
|
;; implementing DNS. It's pushing it and in slightly bad taste to even
|
||||||
'(#"tonyg" #"example")
|
;; call this DNS.
|
||||||
1
|
(define (answer-question q w cache)
|
||||||
24
|
(match-define (struct* question ([name name])) q)
|
||||||
24
|
|
||||||
30
|
|
||||||
10))
|
(values ( (world-message (dns-message query-id
|
||||||
(list (rr '(#"localhost" #"example") 'a 'in 30 '#(127 0 0 1))
|
'response
|
||||||
(rr '(#"example") 'mx 'in 30 (mx 5 '(#"localhost" #"example")))
|
'query
|
||||||
(rr '(#"example") 'mx 'in 30 (mx 10 '(#"subns" #"example")))
|
'non-authoritative
|
||||||
(rr '(#"google" #"example") 'cname 'in 30 '(#"www" #"google" #"com"))
|
'not-truncated
|
||||||
(rr '(#"roar" #"example") 'a 'in 30 '#(192 168 1 1))
|
recursion-desired
|
||||||
(rr '(#"ns" #"example") 'a 'in 30 '#(127 0 0 1))
|
'recursion-available
|
||||||
(rr '(#"hello" #"example") 'txt 'in 30 '(#"Hello CRASH"))
|
'no-error
|
||||||
(rr '(#"subzone" #"example") 'ns 'in 30 '(#"subns" #"example"))
|
questions
|
||||||
(rr '(#"subns" #"example") 'a 'in 30 '#(127 0 0 2))))
|
(list)
|
||||||
|
(list)
|
||||||
|
(list))
|
||||||
|
#f
|
||||||
|
request-source))
|
||||||
|
old-world))
|
||||||
|
|
||||||
|
(define (handle-reply r old-world)
|
||||||
|
(error 'handle-reply "Unimplemented"))
|
||||||
|
|
||||||
|
(start-proxy 5555
|
||||||
|
(list (rr '() 'ns 'in 30 '(#"google-public-dns-a" #"google" #"com"))
|
||||||
|
(rr '(#"google-public-dns-a" #"google" #"com") 'a 'in 30 '#(8 8 8 8))))
|
||||||
|
|
|
@ -26,36 +26,6 @@
|
||||||
;; determines subzones based on the RRs it is configured with at
|
;; determines subzones based on the RRs it is configured with at
|
||||||
;; startup.
|
;; startup.
|
||||||
|
|
||||||
(define (authoritativeness-for dn soa-rr)
|
|
||||||
(if (in-bailiwick? dn (rr-name soa-rr))
|
|
||||||
'authoritative
|
|
||||||
'non-authoritative))
|
|
||||||
|
|
||||||
;; ASSUMPTION: r1 and r2 are both DNS replies to the same query.
|
|
||||||
;; ASSUMPTION: no response-codes other than no-error or name-error are in use.
|
|
||||||
(define (merge-replies r1 r2)
|
|
||||||
(dns-message (dns-message-id r1)
|
|
||||||
'response
|
|
||||||
'query
|
|
||||||
(if (and (eqv? (dns-message-authoritative r1) 'authoritative)
|
|
||||||
(eqv? (dns-message-authoritative r2) 'authoritative))
|
|
||||||
'authoritative
|
|
||||||
'non-authoritative)
|
|
||||||
'not-truncated
|
|
||||||
(dns-message-recursion-desired r1)
|
|
||||||
'no-recursion-available
|
|
||||||
(if (and (eqv? (dns-message-response-code r1) 'name-error)
|
|
||||||
(eqv? (dns-message-response-code r2) 'name-error))
|
|
||||||
'name-error
|
|
||||||
'no-error)
|
|
||||||
(dns-message-questions r1)
|
|
||||||
(listset-union (dns-message-answers r1) (dns-message-answers r2))
|
|
||||||
(listset-union (dns-message-authorities r1) (dns-message-authorities r2))
|
|
||||||
(listset-union (dns-message-additional r1) (dns-message-additional r2))))
|
|
||||||
|
|
||||||
(define (listset-union xs1 xs2)
|
|
||||||
(set->list (set-union (list->set xs1) (list->set xs2))))
|
|
||||||
|
|
||||||
(struct bad-dns-packet (detail host port reason) #:prefab)
|
(struct bad-dns-packet (detail host port reason) #:prefab)
|
||||||
(struct dns-request (message host port) #:prefab)
|
(struct dns-request (message host port) #:prefab)
|
||||||
(struct dns-reply (message host port) #:prefab)
|
(struct dns-reply (message host port) #:prefab)
|
||||||
|
@ -116,7 +86,7 @@
|
||||||
(dns-message (dns-message-id request-message)
|
(dns-message (dns-message-id request-message)
|
||||||
'response
|
'response
|
||||||
'query
|
'query
|
||||||
(authoritativeness-for name soa-rr)
|
(if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative)
|
||||||
'not-truncated
|
'not-truncated
|
||||||
(dns-message-recursion-desired request-message)
|
(dns-message-recursion-desired request-message)
|
||||||
'no-recursion-available
|
'no-recursion-available
|
||||||
|
@ -127,59 +97,39 @@
|
||||||
(set->list additional)))
|
(set->list additional)))
|
||||||
|
|
||||||
(define (answer-question q make-reply)
|
(define (answer-question q make-reply)
|
||||||
(let resolve ((name (question-name q)))
|
;; Notice that we claim to be authoritative for our configured
|
||||||
;; Notice that we claim to be authoritative for our configured
|
;; zone. If we ever answer name-error, that means there are no RRs
|
||||||
;; zone. If we ever answer name-error, that means there are no
|
;; *at all* for the queried name. If there are RRs for the queried
|
||||||
;; RRs *at all* for the queried name. If there are RRs for the
|
;; name, but they happen not to be the ones asked for, name-error
|
||||||
;; queried name, but they happen not to be the ones asked for,
|
;; must *not* be returned: instead, a normal no-error reply is
|
||||||
;; name-error must *not* be returned: instead, a normal
|
;; sent with an empty answer section.
|
||||||
;; no-error reply is sent with an empty answer section.
|
;;
|
||||||
;;
|
;; If we wanted to support caching of negative replies, we'd
|
||||||
;; If we wanted to support caching of negative replies, we'd
|
;; follow the guidelines in section 4.3.4 "Negative response
|
||||||
;; follow the guidelines in section 4.3.4 "Negative response
|
;; caching" of RFC1034, adding our zone SOA with an appropriate
|
||||||
;; caching" of RFC1034, adding our zone SOA with an
|
;; TTL to the additional section of the reply.
|
||||||
;; appropriate TTL to the additional section of the reply.
|
;;
|
||||||
;;
|
;; TODO: We support returning out-of-bailiwick records (glue)
|
||||||
;; TODO: We support returning out-of-bailiwick records (glue)
|
;; here. Reexamine the rules for doing so.
|
||||||
;; here. Reexamine the rules for doing so.
|
(define (build-referral q ns-rrset)
|
||||||
(cond
|
(question-result q
|
||||||
((hash-ref zone name #f) =>
|
zone
|
||||||
;; The full name matches in our zone database.
|
ns-rrset
|
||||||
(lambda (rrset)
|
(set soa-rr)
|
||||||
(define filtered-rrs (filter-rrs rrset (question-type q) (question-class q)))
|
(additional-section/a zone (set-map ns-rrset rr-rdata))))
|
||||||
(define cnames (filter-by-type rrset 'cname))
|
(match (resolve q soa-rr zone build-referral)
|
||||||
(define base-reply (make-reply name
|
[#f
|
||||||
#f
|
(make-reply (question-name q)
|
||||||
(set-union cnames filtered-rrs)
|
(in-bailiwick? (question-name q) (rr-name soa-rr))
|
||||||
(set soa-rr)
|
(set)
|
||||||
(set)))
|
(set)
|
||||||
;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a.
|
(set))]
|
||||||
(if (and (not (set-empty? cnames))
|
[(question-result _ _ answers authorities additional)
|
||||||
(not (eqv? (question-type q) 'cname)))
|
(make-reply (question-name q)
|
||||||
(foldl (lambda (cname-rr current-reply)
|
#f
|
||||||
(merge-replies current-reply
|
answers
|
||||||
(resolve (rr-rdata cname-rr))))
|
authorities
|
||||||
base-reply
|
additional)]))
|
||||||
(set->list cnames))
|
|
||||||
base-reply)))
|
|
||||||
((referral-for name soa-rr zone) =>
|
|
||||||
;; No full name match, but a referral to somewhere beneath our
|
|
||||||
;; SOA but within our zone.
|
|
||||||
(lambda (ns-rrset)
|
|
||||||
(make-reply name
|
|
||||||
#f
|
|
||||||
ns-rrset
|
|
||||||
(set soa-rr)
|
|
||||||
(additional-section/a zone (set-map ns-rrset rr-rdata)))))
|
|
||||||
(else
|
|
||||||
;; Neither a full name match nor a referral is
|
|
||||||
;; available. Answer name-error (NXDOMAIN) if the queried
|
|
||||||
;; name is in-bailiwick, or a normal no-error otherwise.
|
|
||||||
(make-reply name
|
|
||||||
(in-bailiwick? name (rr-name soa-rr))
|
|
||||||
(set)
|
|
||||||
(set)
|
|
||||||
(set))))))
|
|
||||||
|
|
||||||
;; TODO: check opcode and direction in request
|
;; TODO: check opcode and direction in request
|
||||||
;; TODO: think again about multiple questions in one packet
|
;; TODO: think again about multiple questions in one packet
|
||||||
|
|
63
zonedb.rkt
63
zonedb.rkt
|
@ -3,6 +3,7 @@
|
||||||
;; Noddy representation of a zone, and various zone and RRSet utilities.
|
;; Noddy representation of a zone, and various zone and RRSet utilities.
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
(require racket/match)
|
||||||
(require "api.rkt")
|
(require "api.rkt")
|
||||||
(require "codec.rkt")
|
(require "codec.rkt")
|
||||||
|
|
||||||
|
@ -12,7 +13,9 @@
|
||||||
filter-by-type
|
filter-by-type
|
||||||
referral-for
|
referral-for
|
||||||
additional-section/a
|
additional-section/a
|
||||||
filter-rrs)
|
filter-rrs
|
||||||
|
|
||||||
|
resolve)
|
||||||
|
|
||||||
;; A CompiledZone is a Hash<DomainName,SetOf<RR>>, representing a
|
;; A CompiledZone is a Hash<DomainName,SetOf<RR>>, representing a
|
||||||
;; collection of DNS RRSets indexed by DomainName.
|
;; collection of DNS RRSets indexed by DomainName.
|
||||||
|
@ -52,6 +55,7 @@
|
||||||
(define (filter-by-type rrset type)
|
(define (filter-by-type rrset type)
|
||||||
(set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
|
(set-filter (lambda (rr) (eqv? (rr-type rr) type)) rrset))
|
||||||
|
|
||||||
|
;; TODO: Make limit maybe #f?? Representing no limit, for DNS roots??
|
||||||
(define (referral-for name soa-rr zone)
|
(define (referral-for name soa-rr zone)
|
||||||
(define limit (rr-name soa-rr))
|
(define limit (rr-name soa-rr))
|
||||||
(let search ((name name))
|
(let search ((name name))
|
||||||
|
@ -100,3 +104,60 @@
|
||||||
((*) filtered-by-type)
|
((*) filtered-by-type)
|
||||||
(else (set-filter (lambda (rr) (eqv? (rr-class rr) qclass)) filtered-by-type))))
|
(else (set-filter (lambda (rr) (eqv? (rr-class rr) qclass)) filtered-by-type))))
|
||||||
filtered-by-type-and-class)
|
filtered-by-type-and-class)
|
||||||
|
|
||||||
|
;; QuestionResult Maybe<QuestionResult> -> QuestionResult
|
||||||
|
;; Add the supporting facts from r2 into r1, keeping r1's
|
||||||
|
;; question. Replaces the knowledge from r1 with the knowledge from
|
||||||
|
;; r2. Suitable for use when r2 is answering some sub-question of
|
||||||
|
;; r1's question.
|
||||||
|
(define (merge-replies r1 r2)
|
||||||
|
(match r2
|
||||||
|
[#f r1]
|
||||||
|
[(question-result _ k2 n2 u2 d2) ;; a normal result
|
||||||
|
(match-define (question-result q1 k1 n1 u1 d1) r1)
|
||||||
|
(question-result q1
|
||||||
|
k2
|
||||||
|
(set-union n1 n2)
|
||||||
|
(set-union u1 u2)
|
||||||
|
(set-union d1 d2))]))
|
||||||
|
|
||||||
|
(define (resolve q soa-rr knowledge recursive-resolver)
|
||||||
|
;; Extract the pieces of the question:
|
||||||
|
(match-define (question name qtype qclass) q)
|
||||||
|
;; Examine knowledgebase:
|
||||||
|
(cond
|
||||||
|
[(hash-ref knowledge name #f) =>
|
||||||
|
;; The full name matches in our collection of trusted facts.
|
||||||
|
(lambda (rrset)
|
||||||
|
(define filtered-rrs (filter-rrs rrset qtype qclass))
|
||||||
|
(define cnames (filter-by-type rrset 'cname))
|
||||||
|
(define base-reply (question-result q
|
||||||
|
knowledge
|
||||||
|
(set-union cnames filtered-rrs)
|
||||||
|
(if (in-bailiwick? name (rr-name soa-rr))
|
||||||
|
(set soa-rr)
|
||||||
|
(set))
|
||||||
|
(set)))
|
||||||
|
;; Algorithm for CNAME expansion from RFC 1034 4.3.2 step 3a.
|
||||||
|
(if (and (not (set-empty? cnames))
|
||||||
|
(not (eqv? qtype 'cname)))
|
||||||
|
(foldl (lambda (cname-rr current-reply)
|
||||||
|
(merge-replies current-reply
|
||||||
|
(resolve (question (rr-rdata cname-rr) qtype qclass)
|
||||||
|
soa-rr
|
||||||
|
(question-result-knowledge current-reply)
|
||||||
|
recursive-resolver)))
|
||||||
|
base-reply
|
||||||
|
(set->list cnames))
|
||||||
|
base-reply))]
|
||||||
|
[(referral-for name soa-rr knowledge) =>
|
||||||
|
;; No full name match, but a referral to somewhere beneath our SOA
|
||||||
|
;; but within the knowledge we have.
|
||||||
|
(lambda (ns-rrset)
|
||||||
|
(recursive-resolver q ns-rrset))]
|
||||||
|
[else
|
||||||
|
;; Neither a full name match nor a referral is available. Answer
|
||||||
|
;; that we have no relevant information in the zone. It's up to
|
||||||
|
;; the caller to decide whether this means NXDOMAIN or simply an
|
||||||
|
;; empty reply.
|
||||||
|
#f]))
|
||||||
|
|
Loading…
Reference in New Issue