diff --git a/scheme/dnsd/cache.scm b/scheme/dnsd/cache.scm new file mode 100644 index 0000000..d992e4c --- /dev/null +++ b/scheme/dnsd/cache.scm @@ -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 +; +; 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)))))