365 lines
11 KiB
Scheme
365 lines
11 KiB
Scheme
; -----------------------
|
|
; --- 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)))))
|