2011-12-15 16:43:45 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
|
|
|
;; DNS server using simple-udp-service.rkt.
|
|
|
|
|
2011-12-28 17:27:27 +00:00
|
|
|
(require racket/unit)
|
2011-12-15 16:43:45 +00:00
|
|
|
(require racket/match)
|
|
|
|
(require racket/set)
|
|
|
|
(require racket/bool)
|
|
|
|
(require "../racket-bitsyntax/main.rkt")
|
|
|
|
(require "api.rkt")
|
|
|
|
(require "codec.rkt")
|
|
|
|
(require "zonedb.rkt")
|
2012-01-16 22:20:10 +00:00
|
|
|
(require "network-query-sig.rkt")
|
2011-12-28 17:27:27 +00:00
|
|
|
(require "resolver-unit.rkt")
|
2011-12-15 16:43:45 +00:00
|
|
|
(require "dump-bytes.rkt")
|
|
|
|
(require "simple-udp-service.rkt")
|
|
|
|
|
2012-01-16 22:20:10 +00:00
|
|
|
(define-unit network-query@
|
|
|
|
(import)
|
|
|
|
(export network-query^)
|
|
|
|
(define (network-query/addresses q db ns-rr addresses)
|
|
|
|
(error 'network-query/addresses "Forbidden to invoke resolver in server")))
|
|
|
|
|
2011-12-30 18:57:54 +00:00
|
|
|
(define-values/invoke-unit/infer
|
2012-01-16 22:20:10 +00:00
|
|
|
(link resolver@ network-query@))
|
2011-12-28 17:27:27 +00:00
|
|
|
|
2011-12-15 16:43:45 +00:00
|
|
|
;; 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.
|
|
|
|
|
2011-12-15 18:02:10 +00:00
|
|
|
(struct bad-dns-packet (detail host port reason) #:prefab)
|
|
|
|
(struct dns-request (message host port) #:prefab)
|
|
|
|
(struct dns-reply (message host port) #:prefab)
|
|
|
|
|
2011-12-15 16:43:45 +00:00
|
|
|
;; 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
|
2011-12-16 16:42:06 +00:00
|
|
|
udp-packet->dns-message
|
2011-12-16 16:30:18 +00:00
|
|
|
dns-reply?
|
2011-12-16 16:42:06 +00:00
|
|
|
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)])
|
2011-12-15 18:02:10 +00:00
|
|
|
(lambda (unhandled state)
|
|
|
|
(error 'dns-server "Unhandled packet ~v" unhandled))
|
2011-12-15 16:43:45 +00:00
|
|
|
#f
|
|
|
|
#:packet-size-limit 512))
|
|
|
|
|
2011-12-16 16:42:06 +00:00
|
|
|
(define (udp-packet->dns-message packet)
|
2011-12-15 17:18:14 +00:00
|
|
|
(match-define (udp-packet body host port) packet)
|
2011-12-15 18:02:10 +00:00
|
|
|
(with-handlers ((exn? (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)))))
|
2011-12-15 17:18:14 +00:00
|
|
|
|
2011-12-21 21:58:42 +00:00
|
|
|
;; 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.
|
|
|
|
|
2011-12-16 16:42:06 +00:00
|
|
|
(define (dns-reply->udp-packet r)
|
|
|
|
(match-define (dns-reply message host port) r)
|
2011-12-16 16:30:18 +00:00
|
|
|
(udp-packet (dns-message->packet message) host port))
|
|
|
|
|
2011-12-22 19:12:31 +00:00
|
|
|
(define (first-only xs)
|
|
|
|
(if (null? xs)
|
|
|
|
xs
|
|
|
|
(cons (car xs) '())))
|
|
|
|
|
2011-12-15 18:02:10 +00:00
|
|
|
(define (handle-request soa-rr zone request)
|
|
|
|
(match-define (dns-request request-message request-host request-port) request)
|
2011-12-15 16:43:45 +00:00
|
|
|
|
|
|
|
(define (make-reply name send-name-error? answers authorities additional)
|
|
|
|
(dns-message (dns-message-id request-message)
|
|
|
|
'response
|
|
|
|
'query
|
2011-12-22 22:51:39 +00:00
|
|
|
(if (in-bailiwick? name soa-rr) 'authoritative 'non-authoritative)
|
2011-12-15 16:43:45 +00:00
|
|
|
'not-truncated
|
|
|
|
(dns-message-recursion-desired request-message)
|
|
|
|
'no-recursion-available
|
|
|
|
(if send-name-error? 'name-error 'no-error)
|
|
|
|
(dns-message-questions request-message)
|
2011-12-21 22:48:15 +00:00
|
|
|
(rr-set->list answers)
|
|
|
|
(rr-set->list authorities)
|
|
|
|
(rr-set->list additional)))
|
2011-12-15 16:43:45 +00:00
|
|
|
|
|
|
|
(define (answer-question q make-reply)
|
2011-12-21 22:00:12 +00:00
|
|
|
;; 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.
|
2011-12-22 22:51:39 +00:00
|
|
|
(match (resolve-from-zone q zone soa-rr #f (set))
|
2011-12-21 22:00:12 +00:00
|
|
|
[#f
|
|
|
|
(make-reply (question-name q)
|
2011-12-22 22:51:39 +00:00
|
|
|
#t
|
2011-12-21 22:00:12 +00:00
|
|
|
(set)
|
|
|
|
(set)
|
|
|
|
(set))]
|
|
|
|
[(question-result _ _ answers authorities additional)
|
|
|
|
(make-reply (question-name q)
|
|
|
|
#f
|
|
|
|
answers
|
|
|
|
authorities
|
|
|
|
additional)]))
|
2011-12-15 16:43:45 +00:00
|
|
|
|
|
|
|
;; TODO: check opcode and direction in request
|
|
|
|
;; TODO: think again about multiple questions in one packet
|
|
|
|
(map (lambda (q)
|
2011-12-15 18:02:10 +00:00
|
|
|
(dns-reply (answer-question q make-reply) request-host request-port))
|
2011-12-22 19:12:31 +00:00
|
|
|
(first-only (dns-message-questions request-message))))
|
2011-12-15 16:43:45 +00:00
|
|
|
|
2011-12-21 22:49:18 +00:00
|
|
|
(require "test-rrs.rkt")
|
|
|
|
(start-server 5555 test-soa-rr test-rrs)
|