initial release for dnsd.
contains the caching structures and a simple blacklist for the nameserver.
This commit is contained in:
nofreude
parent
d465ef05b7
commit
4b9a16653a
|
|
@ -0,0 +1,170 @@
|
|||
; ----------------------------
|
||||
; --- Query/Response-Cache ---
|
||||
; ----------------------------
|
||||
|
||||
; Cache for dnsd.scm
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; Revised version of the cache implementation seen in dns.scm.
|
||||
|
||||
; The cache stores data that was received during a recursive lookup.
|
||||
; The access-key of the cache consists of a question-name/class/type, the
|
||||
; data is a list of answers/additionals/authority.
|
||||
; It uses r/w-lock to avoid multiple simultaneous writes.
|
||||
|
||||
; Cache-Interface:
|
||||
; -----------------
|
||||
|
||||
; (dnsd-cache-clear!) - Removes the whole data.
|
||||
; (dnsd-cache-clean!) - Removes expired data.
|
||||
; (dnsd-cache-lookup? msg) - Searches for a cached reply.
|
||||
; (dnsd-cache-update! msg) - Updates the data to include the given msg.
|
||||
; (dnsd-cache-pretty-print) - Prints the cache.
|
||||
|
||||
;; Cache:
|
||||
;; ------
|
||||
|
||||
(define-record-type dnsd-cache :dnsd-cache
|
||||
(make-dnsd-cache data lock)
|
||||
dnsd-cache?
|
||||
(data get-dnsd-cache-data) ; cache-data-record-type
|
||||
(lock get-dnsd-cache-lock)) ; r/w-lock
|
||||
|
||||
(define-record-type cache-data :cache-data
|
||||
(make-cache-data answer expires)
|
||||
cache?
|
||||
(answer cache-data-answer) ; an answer as needed by lookup-query
|
||||
(expires cache-data-expires)) ; expiration time of the data (+ ttl (time))
|
||||
|
||||
|
||||
;; Create the cache:
|
||||
(define *dnsd-cache* (make-dnsd-cache (make-string-table) (make-r/w-lock)))
|
||||
|
||||
|
||||
;; Search for the shortest TTL in the message:
|
||||
;; TYPE: message -> number or #f
|
||||
(define (find-shortest-ttl msg)
|
||||
(let loop ((msg msg))
|
||||
(cond
|
||||
((dns-message? msg) (loop (dns-message-reply msg)))
|
||||
((message? msg) (fold-right
|
||||
(lambda (e m)
|
||||
(let ((ttl (resource-record-ttl e)))
|
||||
(if m
|
||||
(if (<= m ttl) m ttl)
|
||||
ttl)))
|
||||
#f
|
||||
(append (message-answers msg)
|
||||
(message-nameservers msg)
|
||||
(message-additionals msg)))))))
|
||||
|
||||
|
||||
;; Make a cache-key from the message:
|
||||
;; TYPE: message -> key-string
|
||||
(define (make-cache-key msg)
|
||||
(let ((question (car (message-questions msg))))
|
||||
(format #f "~a;~a;~a" (question-name question)
|
||||
(message-type-name (question-type question))
|
||||
(message-class-name (question-class question)))))
|
||||
|
||||
|
||||
;; Reset the cache:
|
||||
(define (dnsd-cache-clear!)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-cache-lock *dnsd-cache*)
|
||||
(lambda ()
|
||||
(set! *dnsd-cache*
|
||||
(make-dnsd-cache (make-string-table)
|
||||
(get-dnsd-cache-lock *dnsd-cache*))))))
|
||||
|
||||
|
||||
;; Remove expired data from the cache:
|
||||
(define (dnsd-cache-clean!)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-cache-lock *dnsd-cache*)
|
||||
(lambda ()
|
||||
(let ((time (time))
|
||||
(table (get-dnsd-cache-data *dnsd-cache*)))
|
||||
(table-walk (lambda (k e)
|
||||
(if (< time (cache-data-expires e))
|
||||
#t
|
||||
(table-set! table k #f)))
|
||||
table)))))
|
||||
|
||||
|
||||
; Look for data in the cache. If the found answer is expired return
|
||||
; #f and remove the answer from the cache.
|
||||
; TYPE: message -> '(l-of-answ l-of-auth l-of-addi boolean) or #f
|
||||
(define (dnsd-cache-lookup? msg)
|
||||
(let ((lock (get-dnsd-cache-lock *dnsd-cache*)))
|
||||
(obtain-R/w-lock lock)
|
||||
(let* ((data (get-dnsd-cache-data *dnsd-cache*))
|
||||
(key (make-cache-key msg))
|
||||
(cdata (table-ref data key)))
|
||||
(if cdata
|
||||
(if (< (time) (cache-data-expires cdata))
|
||||
(let ((res (cache-data-answer cdata)))
|
||||
(release-R/w-lock lock)
|
||||
res)
|
||||
(begin
|
||||
(release-R/w-lock lock)
|
||||
(obtain-r/W-lock lock)
|
||||
(table-set! data key #f)
|
||||
(release-r/W-lock lock)
|
||||
#f))
|
||||
(begin
|
||||
(release-R/w-lock lock)
|
||||
#f)))))
|
||||
|
||||
|
||||
;; Add the answer-sections (ansers/authority/additionals) and the authoritative
|
||||
;; flag of a message to the cache:
|
||||
;; TYPE: message -> unspecific
|
||||
(define (dnsd-cache-update! msg)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-cache-lock *dnsd-cache*)
|
||||
(lambda ()
|
||||
(let ((shortest-ttl (find-shortest-ttl msg)))
|
||||
(if (> shortest-ttl 0)
|
||||
(table-set!
|
||||
(get-dnsd-cache-data *dnsd-cache*)
|
||||
(make-cache-key msg)
|
||||
(make-cache-data
|
||||
(list (message-answers msg)
|
||||
(message-nameservers msg)
|
||||
(message-additionals msg)
|
||||
(header-flags (message-header msg))) ; authoritative?
|
||||
(+ (time) shortest-ttl)))
|
||||
#f)))))
|
||||
|
||||
|
||||
;; Display the cache:
|
||||
(define (dnsd-cache-pretty-print)
|
||||
(with-R/w-lock
|
||||
(get-dnsd-cache-lock *dnsd-cache*)
|
||||
(lambda ()
|
||||
(let ((data (get-dnsd-cache-data *dnsd-cache*)))
|
||||
(display "DNSD-CACHE:\n")
|
||||
(display "-----------\n")
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(let ((cache-data (cache-data-answer e)))
|
||||
(display "\n*Question: ")
|
||||
(display k)(newline)
|
||||
(display " ---------\n")
|
||||
(display " Expires in: ")
|
||||
(display (- (cache-data-expires e) (time)))
|
||||
(display " seconds.\n")
|
||||
(display " \n Answer-Section:\n\n")
|
||||
(map (lambda (x) (pretty-print-dns-message x)) (car cache-data))
|
||||
(display " \n Authority-Section:\n\n")
|
||||
(map (lambda (y) (pretty-print-dns-message y)) (cadr cache-data))
|
||||
(display " \n Additionals-Section:\n\n")
|
||||
(map (lambda (z) (pretty-print-dns-message z)) (caddr cache-data))))
|
||||
data)))))
|
||||
Loading…
Reference in New Issue