From b79ca309c4dfe6a312869cfefa85df9ce3acefc0 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 17 Feb 2012 13:42:17 -0500 Subject: [PATCH] Fix cache TTL poisoning; save and load zone data --- codec.rkt | 5 +++- proxy.rkt | 76 +++++++++++++++++++++++++++++++--------------------- test-dns.rkt | 11 ++++++++ test-rrs.rkt | 2 +- zonedb.rkt | 73 ++++++++++++++++++++++++++++++++++++++++++------- 5 files changed, 125 insertions(+), 42 deletions(-) diff --git a/codec.rkt b/codec.rkt index 898ff29..92b538d 100644 --- a/codec.rkt +++ b/codec.rkt @@ -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") diff --git a/proxy.rkt b/proxy.rkt index 886dcf0..e3c2002 100644 --- a/proxy.rkt +++ b/proxy.rkt @@ -23,9 +23,9 @@ ;; For discarding retransmitted requests that we're still working on. (struct active-request (source id) #:transparent) -;; start-proxy : UInt16 ListOf -> 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))) diff --git a/test-dns.rkt b/test-dns.rkt index 45e3e83..b800c55 100644 --- a/test-dns.rkt +++ b/test-dns.rkt @@ -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)))) diff --git a/test-rrs.rkt b/test-rrs.rkt index f3fdde8..40eb49b 100644 --- a/test-rrs.rkt +++ b/test-rrs.rkt @@ -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)))) diff --git a/zonedb.rkt b/zonedb.rkt index 5ac32ca..5a01ba6 100644 --- a/zonedb.rkt +++ b/zonedb.rkt @@ -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 CompiledZone -> (values CompiledZone Hash) +;; Maybe 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)))))