racket-dns-2012/simplified-driver.rkt

157 lines
5.7 KiB
Racket

#lang racket/base
;; DNS server using simple-udp-service.rkt.
(require racket/unit)
(require racket/match)
(require racket/set)
(require racket/bool)
(require "../racket-bitsyntax/main.rkt")
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require "resolver.rkt")
(require "simple-udp-service.rkt")
;; Instantiated with a SOA record for the zone it is serving as well
;; as a zone's worth of DNS data which is used to answer queries
;; authoritatively. Never caches information, never performs recursive
;; queries.
;; Rules:
;; - Answers authoritative NXDOMAIN answers for queries falling within
;; its zone. (This is the only responder entitled to answer NXDOMAIN!)
;; - Answers with referrals for queries falling in subzones. It
;; determines subzones based on the RRs it is configured with at
;; startup.
(struct bad-dns-packet (detail host port reason) #:prefab)
(struct dns-request (message host port) #:prefab)
(struct dns-reply (message host port) #:prefab)
;; start-server : UInt16 RR ListOf<RR> -> Void
;; Starts a server that will answer questions received on the given
;; UDP port based on the RRs it is given and the zone origin specified
;; in the soa-rr given.
(require racket/pretty)
(define (start-server port-number soa-rr rrs)
;; Compile the zone hash table
(define zone (compile-zone-db (cons soa-rr rrs)))
(pretty-print zone)
(start-udp-service
port-number
udp-packet->dns-message
dns-reply?
dns-reply->udp-packet
(message-handlers old-state
[(? bad-dns-packet? p)
(pretty-print p)
(values '() old-state)]
[(? dns-request? r)
(values (handle-request soa-rr zone r) old-state)])
(lambda (unhandled state)
(error 'dns-server "Unhandled packet ~v" unhandled))
#f
#:packet-size-limit 512))
(define (udp-packet->dns-message packet)
(match-define (udp-packet body host port) packet)
(with-handlers ((exn:fail? (lambda (e) (bad-dns-packet body host port 'unparseable))))
(define message (packet->dns-message body))
(case (dns-message-direction message)
((request) (dns-request message host port))
((response) (bad-dns-packet message host port 'unexpected-dns-response)))))
;; TODO: dns-reply->udp-packet may fail! The server may supply some
;; value that isn't a proper DNSMessage. In that case we might like to
;; not send a UDP packet, but instead send out a bad-dns-packet local
;; message for logging etc. (Glossing over the issue of identifying
;; the direction of the message for now.)
;;
;; Once we move to pluggable external-event-sources/relays this will
;; go away: they'll be handlers like anything else, that just happen
;; to have a side effect in some containing (or if not containing, at
;; least *in-scope*) network.
(define (dns-reply->udp-packet r)
(match-define (dns-reply message host port) r)
(udp-packet (dns-message->packet message) host port))
(define (first-only xs)
(if (null? xs)
xs
(cons (car xs) '())))
(define (handle-request soa-rr zone request)
(match-define (dns-request request-message request-host request-port) request)
(define (make-reply name send-name-error? answers authorities additional)
(dns-message (dns-message-id request-message)
'response
'query
(if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative)
'not-truncated
(dns-message-recursion-desired request-message)
'no-recursion-available
(if send-name-error? 'name-error 'no-error)
(dns-message-questions request-message)
(rr-set->list answers)
(rr-set->list authorities)
(rr-set->list additional)))
(define (answer-question q make-reply)
;; Notice that we claim to be authoritative for our configured
;; zone. If we ever answer name-error, that means there are no RRs
;; *at all* for the queried name. If there are RRs for the queried
;; name, but they happen not to be the ones asked for, name-error
;; must *not* be returned: instead, a normal no-error reply is
;; sent with an empty answer section.
;;
;; 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.
(match-define (question qname qtype qclass #f) q)
(define (expand-cnames worklist ans)
(match worklist
['()
(match-define (complete-answer ns us ds) ans)
(make-reply qname #f ns us ds)]
[(cons next-cname rest)
(define a (resolve-from-zone (question next-cname qtype qclass q) zone soa-rr (set)))
(incorporate-answer a rest ans)]))
(define (incorporate-answer this-answer worklist ans)
(match this-answer
[(partial-answer new-info more-cnames)
(expand-cnames (append worklist more-cnames)
(merge-answers new-info ans))]
[(? complete-answer?)
(expand-cnames worklist
(merge-answers this-answer ans))]
[_ ;; #f or a referral
(expand-cnames worklist ans)]))
(match (resolve-from-zone q zone soa-rr (set))
[#f ;; Signal name-error/NXDOMAIN
(make-reply qname #t (set) (set) (set))]
[(referral _ ns-rrs additional)
(make-reply qname #f ns-rrs (set soa-rr) additional)]
[this-answer
(incorporate-answer this-answer '() (empty-complete-answer))]))
;; TODO: check opcode and direction in request
;; TODO: think again about multiple questions in one packet
(map (lambda (q)
(dns-reply (answer-question q make-reply) request-host request-port))
(first-only (dns-message-questions request-message))))
(require "test-rrs.rkt")
(start-server (test-port-number) test-soa-rr test-rrs)