149 lines
5.8 KiB
Racket
149 lines
5.8 KiB
Racket
#lang racket/base
|
|
;; DNS server using os-big-bang.rkt and os-udp.rkt.
|
|
;;
|
|
;;; Copyright 2010, 2011, 2012, 2013 Tony Garnock-Jones <tonyg@ccs.neu.edu>
|
|
;;;
|
|
;;; This file is part of marketplace-dns.
|
|
;;;
|
|
;;; marketplace-dns is free software: you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU General Public License as
|
|
;;; published by the Free Software Foundation, either version 3 of the
|
|
;;; License, or (at your option) any later version.
|
|
;;;
|
|
;;; marketplace-dns is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with marketplace-dns. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
(require racket/match)
|
|
(require racket/set)
|
|
(require racket/bool)
|
|
(require bitsyntax)
|
|
(require "api.rkt")
|
|
(require "codec.rkt")
|
|
(require "zonedb.rkt")
|
|
(require "resolver.rkt")
|
|
(require syndicate/ground)
|
|
(require syndicate/actor)
|
|
(require syndicate/drivers/udp)
|
|
(require "tk-dns.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.
|
|
|
|
;; (: start-server : Nonnegative-Integer 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)))
|
|
(define local-addr (udp-listener port-number))
|
|
|
|
(display ";; Ready.\n")
|
|
|
|
(run-ground (spawn-udp-driver)
|
|
(dataspace (dns-spy)
|
|
(dns-read-driver local-addr)
|
|
(dns-write-driver local-addr)
|
|
(forever
|
|
(on (message ($ p (bad-dns-packet _ _ _ _)))
|
|
(log-error (pretty-format p)))
|
|
(on (message ($ r (dns-request _ _ _)))
|
|
(let ((reply (handle-request soa-rr zone r)))
|
|
(when reply (send! reply))))))))
|
|
|
|
;; (define-type ReplyMaker (DomainName Boolean (Setof RR) (Setof RR) (Setof RR) -> DNSMessage))
|
|
|
|
;; (: handle-request : RR CompiledZone DNSRequest -> (Option DNSReply))
|
|
(define (handle-request soa-rr zone request)
|
|
(match-define (dns-request request-message request-source request-sink) request)
|
|
|
|
;; (: make-reply : ReplyMaker)
|
|
(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)))
|
|
|
|
;; (: answer-question : Question ReplyMaker -> DNSMessage)
|
|
(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)
|
|
|
|
;; (: expand-cnames : (Listof DomainName) CompleteAnswer -> DNSMessage)
|
|
(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 (cname-question next-cname q) zone soa-rr (set)))
|
|
(incorporate-answer a rest ans)]))
|
|
|
|
;; (: incorporate-answer : Answer (Listof DomainName) CompleteAnswer -> DNSMessage)
|
|
(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? c)
|
|
(expand-cnames worklist (merge-answers c 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
|
|
(match (dns-message-questions request-message)
|
|
['() #f]
|
|
[(cons q _)
|
|
(dns-reply (answer-question q make-reply) request-sink request-source)]))
|
|
|
|
(require "test-rrs.rkt")
|
|
(start-server (test-port-number) test-soa-rr test-rrs)
|