From 4b9a16653ac54d99ee8973d5140a38d9fbbfd925 Mon Sep 17 00:00:00 2001
From: nofreude <nofreude>
Date: Sun, 12 Nov 2006 18:13:14 +0000
Subject: [PATCH] initial release for dnsd.

contains the caching structures and a simple blacklist for the nameserver.
---
 scheme/dnsd/cache.scm | 170 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 170 insertions(+)
 create mode 100644 scheme/dnsd/cache.scm

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 
+;                            <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)))))