sunet/scheme/dnsd/slist.scm

; -----------------------
; --- SLIST/Blacklist ---
; -----------------------

; SLIT-Structure for the recursiv lookup algorithm (resolver.scm).
; The Blacklist is used to store 'bad' Nameserver-IPs.

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

; Naming-Scheme:
; --------------

; dnsd-slist-...
; dnsd-blacklist-...

;; SLIST-Cache

; The SLIST-Structure as described in RFC1034/1035.

; Lock-Safe Cache-Interface:
; ---------------------------

; (dnsd-slist-clear!)                  - Removes the whole data.
; (dnsd-slist-clean!)                  - Removes expired data.
; (dnsd-slist-lookup msg dnsd-options) - Returns nameserver IPs.
; (dnsd-slist-update! msg)             - Stores Nameservers & their IPs.
; (dnsd-slist-pretty-print)            - Prints the slist.


;; Blacklist:

; An IP-Adress can be blacklisted by bad resolver-results in resolver.scm
; This will cause the increment a blacklist-value. After the value reaches
; a threshold the IP will be ignored for some time (dnsd-options).
; 
; After that, the next question for this IP can result in the following:
;  - ignore the IP another round for bad answer
;  - whitelist the IP for a good answer...
;    (A good result will remove any IP from the blacklist.)

; Lock-Safe Cache-Interface:
; ---------------------------

; (dnsd-blacklist! ip . value)         - Blacklist a IP.
; (dnsd-blacklist-clean! dnsd-options)
; (dnsd-blacklist-unlist! ip dnsd-options) 
; (dnsd-blacklist-clear!)
; (dnsd-blacklist-print)


; Stuff:
; ------

; Filter rrs of the given type:
; TYPE: message-type x list-of-rrs -> list-of-rrs
(define (filter-rr-type type list)
  (filter (lambda (e) (eq? (resource-record-type e) type)) list))

(define *debug-info* #f)

; TODO: Do this different:
; Shows the debug-information
(define display-debug
  (lambda args
    (if *debug-info*
	(begin
	  (display "dnsd: ")
	  (map (lambda (e) (display e) (display " ")) args)
	  (newline))
	#f)))


; SLIST:
; ------

(define-record-type dnsd-slist :dnsd-slist
  (make-dnsd-slist data lock)
  dnsd-slist?
  (data get-dnsd-slist-data)     ; slist-data-record-type
  (lock get-dnsd-slist-lock))    ; r/w-lock

(define-record-type slist-data :slist-data
  (make-slist-data answer expires)
  cache?
  (answer slist-data-answer set-slist-data-answer!) ; list-of-rrs
  (expires slist-data-expires)) ; expiration time of the data (+ ttl (time))


; Create the slist:
(define *dnsd-slist* (make-dnsd-slist (make-string-table) (make-r/w-lock)))


;; Search for the shortest TTL in the message:
;; TYPE: message -> number or #f
(define (dnsd-slist-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 (message-additionals msg))))))


;; Make a SLIST-Key from a message:
;; TYPE: message -> key-string
(define (make-slist-key msg)
  (let ((question (car (message-questions msg))))
    (format #f "~a;~a" (string-downcase (question-name question))
	    (message-class-name (question-class question)))))


;; Resets the SLIST:
(define (dnsd-slist-clear!)
  (with-r/W-lock
   (get-dnsd-slist-lock *dnsd-slist*)
   (lambda ()
     (set! *dnsd-slist* (make-dnsd-slist (make-string-table)
					 (get-dnsd-slist-lock *dnsd-slist*))))))


;; Removes expired data from the SLIST:
(define (dnsd-slist-clean!)
  (with-r/W-lock
   (get-dnsd-slist-lock *dnsd-slist*)
   (lambda ()
     (let ((time (time))
	   (table (get-dnsd-slist-data *dnsd-slist*)))
       (table-walk (lambda (k e)
		     (if (< time (slist-data-expires e))
			 #t
			 (table-set! table k #f)))
		   table)))))


;; Add the results of the given response to the cache-data
;; a min ttl is given to the NS so that the rec-lookup-algorithm
;; will be able to do it's work properly... .
;; TYPE: message -> unspecific
(define (dnsd-slist-update-ns! msg)
  (with-r/W-lock
   (get-dnsd-slist-lock *dnsd-slist*)
   (lambda ()
     (and-let* ((key (make-slist-key msg)))
       (let* ((ttl (dnsd-slist-find-shortest-ttl msg))
	      (min-ttl (if (< ttl 120) 120 ttl))
	      (expires (+ (time) min-ttl)))
	 (table-set! 
	  (get-dnsd-slist-data *dnsd-slist*)
	  key 
	  (make-slist-data (message-additionals msg) expires)))))))


; Take the nameservers & the corresponding IPs from a message and
; (if no entry is present) adds the nameservers to the cache to be looked up
; via the nameserver-zone (found as resource-record name of the servers)
; Some server return nameserver resource records in the answer-section
; others in the additional section.
;; TYPE: message -> unspecific
(define (dnsd-slist-update! msg)
  (display-debug "Updating SLIST! Adding a Nameserver.")
  (and-let* ((ns-rrs (append (message-answers msg) (message-nameservers msg)))
	     (additionals (message-additionals msg))
	     (good-ns-rrs (filter-rr-type (message-type ns) ns-rrs))
	     (whatever (not (null? good-ns-rrs)))
	     (good-additionals (filter-rr-type (message-type a) additionals))
	     (whatever (not (null? good-additionals)))
	     (class (question-class (car (message-questions msg))))
	     (nameserver-zone (resource-record-name (car good-ns-rrs)))
	     (good-ns-rrs (filter (lambda (e) 
				    (string-ci=? nameserver-zone 
						 (resource-record-name e)))
				  good-ns-rrs))
	     (nameserver-names (map (lambda (e)
				      (resource-record-data-ns-name
				       (resource-record-data e))) good-ns-rrs))
	     (good-additionals (filter
				(lambda (e)
				  (fold-right 
				   (lambda (name b)
				     (if b b (string-ci=? 
					      name (resource-record-name e))))
				   #f nameserver-names))
				good-additionals))
	     (new-msg 
	      (make-message (message-header msg)
			    (list (make-question nameserver-zone
						 (message-type ns) class))
				    good-ns-rrs '() good-additionals '())))
	    (dnsd-slist-update-ns! new-msg)))


;; Look for the IPs of the nameservers in the cache.
;; TYPE: message -> list-of-address32
(define (dnsd-slist-lookup msg dnsd-options)
  ;; Look for data in the slist:
  (define (dnsd-slist-lookup-int msg)
    (let ((lock (get-dnsd-slist-lock *dnsd-slist*)))
      (obtain-R/w-lock lock)
      (let* ((data (get-dnsd-slist-data *dnsd-slist*))
	     (key (make-slist-key msg))
	     (cdata (table-ref data key)))
	(if cdata
	    (if (< (time) (slist-data-expires cdata))
		(begin
		  (let ((res (slist-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)))))
  ;; ---
  (and-let* ((additionals (dnsd-slist-lookup-int msg))
	     (ns-a-rrs (filter-rr-type (message-type a) additionals))
	     (ip-list (map (lambda (e) (resource-record-data-a-ip 
					(resource-record-data e))) ns-a-rrs)))
    ;; Filter good from blacklisted IPs:
    (with-R/w-lock
     (get-dnsd-blacklist-lock *blacklist*)
     (lambda ()
       (filter (lambda (ip)
		 (let ((element (table-ref (get-dnsd-blacklist-data *blacklist*)
					   ip)))
		   (cond
		    ;; IP isn't in the blacklist-table
		    ((not element) #t)
		    ;; The IP hasn't been blacklisted blacklist-value-times
		    ((>= (dnsd-options-blacklist-value dnsd-options)
			 (cdr element)) #t)
		    ;; Blacklisted longer than blacklist-time-value. Try again.
		    ((<= (+ (dnsd-options-blacklist-time dnsd-options)
			    (car element))
			 (time)) #t)
		    ;; Don't use the IP
		    (else #f))))
		 ip-list)))))
	    


;; Blacklist:
;; ----------

(define-record-type dnsd-blacklist :dnsd-blacklist
  (make-dnsd-blacklist data lock)
  dnsd-blacklist?
  (data get-dnsd-blacklist-data)     ; a integer-table
  (lock get-dnsd-blacklist-lock))    ; r/w-lock


(define *blacklist* (make-dnsd-blacklist (make-integer-table) (make-r/w-lock)))


;; Add a IP to the blacklist:
;; TYPE: address32 -> unspecific
(define (dnsd-blacklist! ip . value)
  (with-r/W-lock
   (get-dnsd-blacklist-lock *blacklist*)
   (lambda ()
     (let* ((table (get-dnsd-blacklist-data *blacklist*))
	    (element (table-ref table ip))
	    (value (if (null? value)
		       1
		       (car value))))
       (if element
	   (table-set! table ip (cons (time) (+ value (cdr element))))
	   (table-set! table ip (cons (time) value)))))))


;; Removes the given ip from the list:
;; TYPE address32 -> unspecific
(define (dnsd-blacklist-unlist! ip dnsd-options)
  (with-r/W-lock
   (get-dnsd-blacklist-lock *blacklist*)
   (lambda ()
     (let ((blacklist (get-dnsd-blacklist-data *blacklist*)))
       (if (and (table-ref blacklist ip)
		(< (cdr (table-ref blacklist ip))
		   (dnsd-options-blacklist-value dnsd-options)))
	   (table-set! blacklist ip #f)
	   #f)))))


;; Remove all blacklisted IPs:
(define (dnsd-blacklist-clear!)
  (with-r/W-lock
   (get-dnsd-blacklist-lock *blacklist*)
   (lambda ()
     (set! *blacklist* (make-dnsd-blacklist 
			(make-integer-table)
			(get-dnsd-blacklist-lock *blacklist*))))))


;; Deprecated:
;; Remove old entries:
; (define (dnsd-blacklist-clean! dnsd-options)
;   (with-r/W-lock
;    (get-dnsd-blacklist-lock *blacklist*)
;    (lambda ()
;      (table-walk 
;       (lambda (key element)
; 	(if (< (dnsd-options-blacklist-time dnsd-options)
; 	       (- (time) (car element)))
; 	    (table-set! (get-dnsd-blacklist-data *blacklist*) key #f)))
;       (get-dnsd-blacklist-data *blacklist*)))))


;; Display SLIST / Blacklist:
;; --------------------------

;; Display the blacklisted IPs:
(define (dnsd-blacklist-print)
  (with-R/w-lock
   (get-dnsd-blacklist-lock *blacklist*)
   (lambda ()
     (let ((data (get-dnsd-blacklist-data *blacklist*))
	   (current-time (time)))
       (display "DNSD-Blacklist:\n")
       (display "---------------\n")
       (table-walk
	(lambda (key element)
	  (display "\nIP: ")
	  (display (address32->ip-string key))
	  (display " with blacklist-value: ")
	  (display (cdr element))
	  (display " [with age ")
	  (display (- current-time (car element)))
	  (display "s.]")
	  (newline))
	data)))))
  
;; Display the SLIST:
(define (dnsd-slist-pretty-print)
  (with-R/w-lock
   (get-dnsd-slist-lock *dnsd-slist*)
   (lambda ()
     (let ((data (get-dnsd-slist-data *dnsd-slist*)))
       (display "DNSD-SLIST:\n")
       (display "-----------\n")
       (table-walk
	(lambda (k e)
	  (let ((slist-data (slist-data-answer e)))
	    (display "\n*Zone: ")
	    (display k)(newline)
	    (display " ---------\n")
	    (display " Expires in: ")
	    (display (- (slist-data-expires e) (time)))
	    (display " seconds.\n")
	    (display " \n  Nameservers-Section:\n\n")
	    (map (lambda (y) (pretty-print-dns-message y))
		      slist-data)))
	data)))))