Crude imperative drivers, to get a feel for the system
This commit is contained in:
Tony Garnock-Jones
parent
521d5578b9
commit
30590bb41a
|
|
@ -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<RR> -> Hash<DomainName,ListSetOf<RR>>
|
||||
;; 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<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-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))))
|
||||
|
|
@ -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)
|
||||
Loading…
Reference in New Issue