sunet/scheme/dnsd/cache.scm

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