syndicate-lang
/
racket-dns-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fix cache TTL poisoning; save and load zone data

This commit is contained in:
Tony Garnock-Jones 2012-02-17 13:42:17 -05:00
parent 4e7cc96d1b
commit b79ca309c4
5 changed files with 125 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
codec.rkt
View File

@ -9,7 +9,10 @@
packet->dns-message
dns-message->packet
max-ttl)
max-ttl
;; For the use of zonedb's save/load routines, etc.
t:rr)
(require "api.rkt")
(require "mapping.rkt")

76
proxy.rkt
View File

@ -23,9 +23,9 @@
;; For discarding retransmitted requests that we're still working on.
(struct active-request (source id) #:transparent)
;; start-proxy : UInt16 ListOf<RR> -> Void
;; start-proxy : UInt16 CompiledZone -> Void
(require racket/pretty)
(define (start-proxy port-number rrs)
(define (start-proxy port-number zone)
(define boot-server
(os-big-bang 'no-state/boot-server
@ -54,7 +54,7 @@
(spawn (dns-read-driver c))
(spawn (dns-write-driver c))
(spawn (packet-dispatcher s))
(spawn (question-dispatcher (compile-zone-db rrs) c)))])))
(spawn (question-dispatcher zone c)))])))
(ground-vm (os-big-bang (void)
;;(spawn udp-spy)
@ -140,33 +140,43 @@
(send-message (answer->reply original-question answer)))])))]))
(define (question-dispatcher zone0 client-sock)
(os-big-bang zone0
;; TODO: consider deduping questions here too?
(subscribe 'question-handler-factory
(message-handlers zone
[`(debug-dump)
(with-output-to-file "zone-proxy.dump"
(lambda ()
(display "----------------------------------------------------------------------\n")
(display (seconds->date (current-seconds)))
(newline)
(for* ([(name rrmap) zone] [(rr expiry) rrmap])
(write (list rr expiry))
(newline))
(newline))
#:mode 'text
#:exists 'append)
zone]
[(? question? q)
(transition zone
(spawn (question-handler zone q client-sock)))]
[(network-reply _ answer)
(define-values (new-zone timers) (incorporate-complete-answer answer zone))
(transition new-zone
(for/list ([(name ttl) timers])
(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) #t))))]
[(timer-expired (list 'check-dns-expiry name) _)
(zone-expire-name zone name)]))))
(define (transition-and-set-timers new-zone timers)
(transition new-zone
(for/list ([timerspec timers])
(match-define (cons name ttl) timerspec)
(send-message (set-timer (list 'check-dns-expiry name) (* ttl 1000) #t)))))
(os-big-bang/transition
(extend-transition (let-values (((expired-zone timers) (zone-expire zone0)))
(transition-and-set-timers expired-zone timers))
;; TODO: consider deduping questions here too?
(subscribe 'question-handler-factory
(message-handlers zone
[`(debug-dump)
(with-output-to-file "zone-proxy.zone"
(lambda ()
(write-bytes (bit-string->bytes (zone->bit-string zone))))
#:mode 'binary
#:exists 'replace)
(with-output-to-file "zone-proxy.dump"
(lambda ()
(display "----------------------------------------------------------------------\n")
(display (seconds->date (current-seconds)))
(newline)
(for* ([(name rrmap) zone] [(rr expiry) rrmap])
(write (list rr expiry))
(newline))
(newline))
#:mode 'text
#:exists 'append)
zone]
[(? question? q)
(transition zone
(spawn (question-handler zone q client-sock)))]
[(network-reply _ answer)
(define-values (new-zone timers) (incorporate-complete-answer answer zone))
(transition-and-set-timers new-zone timers)]
[(timer-expired (list 'check-dns-expiry name) _)
(zone-expire-name zone name)])))))
(struct question-state (zone q client-sock nameservers-tried retry-count) #:transparent)
(struct expanding-cnames (q accumulator remaining-count) #:transparent)
@ -231,5 +241,9 @@
cnames))])]))
(require "test-rrs.rkt")
(require racket/file)
(file-stream-buffer-mode (current-output-port) 'none)
(start-proxy (test-port-number) test-roots)
(start-proxy (test-port-number)
(if (file-exists? "zone-proxy.zone")
(bit-string->zone (file->bytes "zone-proxy.zone"))
(compile-zone-db test-roots)))

11
test-dns.rkt
View File

@ -2,6 +2,8 @@
(require "api.rkt")
(require "codec.rkt")
(require "zonedb.rkt")
(require "test-rrs.rkt")
(require rackunit)
@ -438,3 +440,12 @@
(rr (domain '(#"ns2" #"google" #"com")) 'a 'in 2737 '#(216 239 34 10))
(rr (domain '(#"ns3" #"google" #"com")) 'a 'in 2737 '#(216 239 36 10))
(rr (domain '(#"ns4" #"google" #"com")) 'a 'in 2737 '#(216 239 38 10))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Zone saving/loading.
(check-equal? (compile-zone-db test-rrs)
(bit-string->zone (zone->bit-string (compile-zone-db test-rrs))))
(check-equal? (compile-zone-db test-roots)
(bit-string->zone (zone->bit-string (compile-zone-db test-roots))))

2
test-rrs.rkt
View File

@ -22,7 +22,7 @@
(rr (domain '(#"roar" #"example")) 'a 'in 30 '#(192 168 1 1))
(rr (domain '(#"alias" #"example")) 'cname 'in 30 (domain '(#"roar" #"example")))
(rr (domain '(#"ns" #"example")) 'a 'in 30 '#(127 0 0 1))
(rr (domain '(#"hello" #"example")) 'txt 'in 30 (domain '(#"Hello CRASH")))
(rr (domain '(#"hello" #"example")) 'txt 'in 30 '(#"Hello CRASH"))
(rr (domain '(#"subzone" #"example")) 'ns 'in 30 (domain '(#"subns" #"example")))
(rr (domain '(#"subns" #"example")) 'a 'in 30 '#(127 0 0 2))))

73
zonedb.rkt
View File

@ -6,11 +6,13 @@
(require racket/match)
(require "api.rkt")
(require "codec.rkt")
(require "../racket-bitsyntax/main.rkt")
(provide zone-ref
zone-includes-name?
incorporate-complete-answer
zone-expire-name
zone-expire
empty-zone-db
compile-zone-db
compiled-zone?
@ -18,7 +20,9 @@
set-filter
filter-by-type
filter-rrs
rr-set->list)
rr-set->list
zone->bit-string
bit-string->zone)
;; An InfiniteLifetime is an (infinite-lifetime RelativeSeconds), a
;; specification of the TTL to use when sending a non-expiring RR to a
@ -31,6 +35,10 @@
;; time associated with it or has an InfiniteLifetime associated with
;; it, in which case it should not expire.
;; A Timers is a SetOf<(cons DomainName AbsoluteSeconds)>,
;; representing a collection of timeouts that should be set against
;; names to to see if their associated RRs have expired.
;; 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.
@ -69,22 +77,23 @@
(+ base-time (rr-ttl resource0))
(infinite-lifetime (rr-ttl resource0))))
(define resource (struct-copy rr resource0 [ttl 0]))
(hash-set db (rr-name resource)
(hash-set (hash-ref db (rr-name resource) hash) resource expiry)))
(define name (rr-name resource))
(define old-expirymap (hash-ref db name hash))
(if (hash-has-key? old-expirymap resource) ;; don't update TTLs if entry exists
db
(hash-set db name (hash-set old-expirymap resource expiry))))
;; Maybe<CompleteAnswer> CompiledZone -> (values CompiledZone Hash<Name,AbsoluteSeconds>)
;; Maybe<CompleteAnswer> CompiledZone -> (values CompiledZone Timers)
(define (incorporate-complete-answer ans db)
(match ans
[#f
(values db (hash))]
(values db (set))]
[(complete-answer ns us ds)
(define now (current-inexact-seconds))
(for/fold ([db db] [timers (hash)])
(for/fold ([db db] [timers (set)])
([rr (in-sequences ns us ds)])
(values ((incorporate-rr now) rr db)
(hash-update timers (rr-name rr)
(lambda (old-ttl) (min old-ttl (rr-ttl rr)))
max-ttl)))]))
(set-add timers (cons (rr-name rr) (rr-ttl rr)))))]))
;; CompiledZone DomainName -> CompiledZone
;; Checks the given name to see if there are any expiring records, and
@ -100,6 +109,24 @@
(hash-remove db name)
(hash-set db name new-expirymap)))
;; CompiledZone -> (values CompiledZone Timers)
;; Used to freshen a saved zone when it is loaded from disk.
(define (zone-expire zone)
(for/fold ([zone zone] [timers (set)])
([name (hash-keys zone)])
(define new-zone (zone-expire-name zone name))
(cond
[(hash-ref new-zone name #f) =>
(lambda (expirymap)
(values new-zone
(set-union (list->set
(map (lambda (e) (cons name e))
(filter (lambda (e) (not (infinite-lifetime? e)))
(hash-values expirymap))))
timers)))]
[else
(values new-zone timers)])))
;; empty-zone-db : -> CompiledZone
(define (empty-zone-db)
(make-immutable-hash))
@ -155,3 +182,31 @@
(define (rr-set->list rrs)
(append (set->list (filter-by-type rrs 'cname))
(set->list (set-filter (lambda (rr) (not (eqv? (rr-type rr) 'cname))) rrs))))
;; CompiledZone -> Bitstring
;; Produces a serialized form of the zone suitable for saving to disk.
(define (zone->bit-string zone)
(for*/fold ([acc (bit-string)])
([(name rrmap) zone] [(rr expiry) rrmap])
(bit-string-append
acc
(match expiry
[(infinite-lifetime ttl)
(bit-string (rr :: (t:rr)) 1 (ttl :: bits 32))]
[expirytime
(bit-string (rr :: (t:rr)) 0 ((truncate (inexact->exact expirytime)) :: bits 32))]))))
;; Bitstring -> CompiledZone
;; Produces a deserialized form of the zone. Suitable for use in loading from disk.
(define (bit-string->zone bs)
(define now (current-inexact-seconds))
(define empty-packet (bytes))
(let loop ((db (empty-zone-db))
(bs bs))
(bit-string-case bs
([ ]
db)
([ (rr0 :: (t:rr empty-packet)) (= 1) (ttl :: bits 32) (rest :: binary) ]
(loop ((incorporate-rr #f) (struct-copy rr rr0 [ttl ttl]) db) rest))
([ (rr0 :: (t:rr empty-packet)) (= 0) (expirytime :: bits 32) (rest :: binary) ]
(loop ((incorporate-rr now) (struct-copy rr rr0 [ttl (- expirytime now)]) db) rest)))))