diff --git a/driver.rkt b/driver.rkt new file mode 100644 index 0000000..93532e6 --- /dev/null +++ b/driver.rkt @@ -0,0 +1,133 @@ +#lang racket/base + +;; Simple imperative DNS server. + +(require racket/udp) +(require racket/set) +(require racket/bool) +(require (planet tonyg/bitsyntax)) +(require "api.rkt") +(require "codec.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. + +;; compile-db : ListOf -> Hash> +;; Builds an immutable hash table from the given RRs, suitable for +;; quickly looking up answers to queries. +(define (compile-db rrs) + ;; RR Hash -> Hash + (define (incorporate-rr rr db) + (hash-set db (rr-name rr) (set-add (hash-ref db (rr-name rr) (set)) rr))) + (foldl incorporate-rr (make-immutable-hash) rrs)) + +(define (in-bailiwick? dn root) + (cond + ((equal? dn root) #t) + ((null? dn) #f) + (else (in-bailiwick? (cdr dn) root)))) + +;; start-server : UInt16 RR ListOf -> 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-db (cons soa-rr rrs))) + + (pretty-print zone) + + ;; Set up the socket + (define s (udp-open-socket #f #f)) + (udp-bind! s #f port-number) + + (let service-loop () + + (define buffer + (make-bytes 512)) + (define-values (packet-length source-hostname source-port) + (udp-receive! s buffer)) + (define request-message + (packet->dns-message (sub-bit-string buffer 0 (* 8 packet-length)))) + + ;; TODO: check opcode in request + + (define (reply! authoritativeness response-code answers authorities additional) + (define reply-message (dns-message (dns-message-id request-message) + 'response + 'query + authoritativeness + 'not-truncated + (dns-message-recursion-desired request-message) + 'no-recursion-available + response-code + (dns-message-questions request-message) + (set->list answers) + (set->list authorities) + (set->list additional))) + ;;(write reply-message) (newline) + (udp-send-to s source-hostname source-port (dns-message->packet reply-message))) + + ;; TODO: what if there are multiple questions in one request + ;; packet? Single reply, or multiple replies? djbdns looks like + ;; it handles exactly one question per request... + + ;; TODO: what if a question is out-of-bailiwick? No answer, + ;; non-authoritative NXDOMAIN (doesn't seem right), or 'refused + ;; response-code? + +;; TODO: maybe store domain names big-end first? +;; It'd make bailiwick and subzone checks into prefix rather than suffix checks. +;; It makes domain names into paths through the DNS DB tree. + +;; TODO: referral for subzones + + (define (answer-question q) + (define name (question-name q)) + (let ((rrset (hash-ref zone name #f))) + (if (false? rrset) + (reply! 'authoritative + 'name-error + (set) + (set) + (set)) + (reply! (if (in-bailiwick? name (rr-name soa-rr)) 'authoritative 'non-authoritative) + 'no-error + rrset + (set soa-rr) + (set))))) + + ;;(display "----------------------------------------") + ;;(newline) + ;;(write request-message) (newline) + (for-each answer-question (dns-message-questions request-message)) + + (service-loop))) + +(start-server 5555 + (rr '(#"example") 'soa 'in 30 + (soa '(#"ns" #"example") + '(#"tonyg" #"example") + 1 + 24 + 24 + 30 + 10)) + (list (rr '(#"localhost" #"example") 'a 'in 30 '#(127 0 0 1)) + (rr '(#"example") 'mx 'in 30 (mx 5 '(#"localhost" #"example"))) + (rr '(#"example") 'mx 'in 30 (mx 10 '(#"subns" #"example"))) + (rr '(#"google" #"example") 'cname 'in 30 '(#"www" #"google" #"com")) + (rr '(#"ns" #"example") 'a 'in 30 '#(127 0 0 1)) + (rr '(#"subzone" #"example") 'ns 'in 30 '(#"subns" #"example")) + (rr '(#"subns" #"example") 'a 'in 30 '#(127 0 0 2)))) diff --git a/stress.rkt b/stress.rkt new file mode 100644 index 0000000..bb65418 --- /dev/null +++ b/stress.rkt @@ -0,0 +1,67 @@ +#lang racket/base + +;; Simple stress-tester and performance measurement tool for DNS +;; implementations. + +(require racket/udp) +(require racket/set) +(require (planet tonyg/bitsyntax)) +(require "api.rkt") +(require "codec.rkt") + +(require racket/pretty) + +(define latencies (make-vector 200 0)) +(define latency-pos 0) +(define (record-latency-ms! ms) + (vector-set! latencies latency-pos ms) + (set! latency-pos (modulo (+ latency-pos 1) (vector-length latencies))) + (when (zero? latency-pos) + (for-each display (list ";; Mean latency "(/ (for/sum ((i latencies)) i) + (vector-length latencies))"ms\n")))) + +(define (stress hostname port-number count rate) + (define s (udp-open-socket #f #f)) + + (define start-time (current-inexact-milliseconds)) + (let loop ((remaining count)) + (define request-message (dns-message (random 65536) + 'request + 'query + 'non-authoritative + 'not-truncated + 'recursion-desired + 'no-recursion-available + 'no-error + (list (question '(#"example") '* '*)) + '() + '() + '())) + + (define now (current-inexact-milliseconds)) + (define sent-count (- count remaining)) + (define delta-ms (- now start-time)) + (define current-rate (/ sent-count (/ delta-ms 1000.0))) + + (when (> current-rate rate) + (define target-delta-sec (/ sent-count rate)) + (sleep (- target-delta-sec (/ delta-ms 1000)))) + + (when (zero? (modulo sent-count rate)) + (for-each display (list ";; Sent "sent-count" at "rate" in "delta-ms"ms\n"))) + + (when (positive? remaining) + (define sent-time (current-inexact-milliseconds)) + (udp-send-to s hostname port-number (dns-message->packet request-message)) + + (define buffer (make-bytes 512)) + (define-values (packet-length source-hostname source-port) + (udp-receive! s buffer)) + (define received-time (current-inexact-milliseconds)) + (define reply (packet->dns-message (sub-bit-string buffer 0 (* 8 packet-length)))) + + ;;(pretty-print reply) + (record-latency-ms! (- received-time sent-time)) + (loop (- remaining 1))))) + +(stress "localhost" 5555 100000 500)