initial release for dnsd.
This commit is contained in:
nofreude
parent
50df77a8a8
commit
1e320f445c
|
|
@ -0,0 +1,82 @@
|
|||
***********************
|
||||
*** README for DNSD ***
|
||||
***********************
|
||||
|
||||
Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
<nofreude@informatik.uni-tuebingen.de>
|
||||
For copyright information, see the file COPYING which comes with
|
||||
the distribution.
|
||||
|
||||
|
||||
RUNNING THE NAMESERVER:
|
||||
-----------------------
|
||||
|
||||
1) Install SCSH, SUnet and SUnterlib
|
||||
---------------------------------
|
||||
|
||||
For instructions see www.scsh.net
|
||||
|
||||
|
||||
2) The configuration
|
||||
-----------------
|
||||
|
||||
There is a folder etc/ containing the files
|
||||
|
||||
dnsd-options.scm
|
||||
dnsd-zones.scm
|
||||
dnsd-pre.scm
|
||||
dnsd-post.scm
|
||||
|
||||
and some additional masterfile-examples.
|
||||
|
||||
You can copy this files to a directory of your liking
|
||||
or simply use the given path (from the SUnet-installation).
|
||||
|
||||
Either way, the path will be called <path-to-options>.
|
||||
|
||||
|
||||
You can customize the files:
|
||||
|
||||
2.1) dnsd-options.scm
|
||||
|
||||
Options for DNSD. Open the file for documentation.
|
||||
|
||||
|
||||
2.2) dnsd-zones.scm
|
||||
|
||||
Add/remove zones to DNSD. Documentation is included in the file.
|
||||
|
||||
|
||||
2.3) dnsd-pre.scm / dnsd-post.scm
|
||||
|
||||
You can customize the behaviour of query-processing within these
|
||||
two files.
|
||||
|
||||
|
||||
3) Run SCSH:
|
||||
---------
|
||||
|
||||
Load the CML-API from SUnterlib and SUnet.
|
||||
|
||||
> scsh -lel cml/load.scm -lel sunet/load.scm
|
||||
|
||||
|
||||
4) SCSH-REPL:
|
||||
----------
|
||||
|
||||
>,in dnsd
|
||||
|
||||
Start DNSD with
|
||||
|
||||
dnsd> (dnsd-start)
|
||||
|
||||
if the current working-directory is <path-to-options> or else use
|
||||
|
||||
dnsd> (dnsd-start <path-to-options>)
|
||||
|
||||
|
||||
5) While running DNSD:
|
||||
-------------------
|
||||
|
||||
* Reload the file dnsd-options.scm with the POSIX-signal USR1.
|
||||
* Reload the file dnsd-zones.scm with the POSIX-signal USR2.
|
||||
|
|
@ -0,0 +1,134 @@
|
|||
;; ------------------------
|
||||
;; --- Database-Options ---
|
||||
;; ------------------------
|
||||
|
||||
; Database-Options for DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; 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.
|
||||
|
||||
; The format and style of the option procedures is the same as seen
|
||||
; in the SUNet HTTPD & FTPD - Files
|
||||
|
||||
|
||||
(define-record-type dnsddb-options :dnsddb-options
|
||||
(really-make-dnsddb-options name class type primary? file filetype master-name master-ip)
|
||||
dnsddb-options?
|
||||
(name dnsddb-options-name set-dnsddb-options-name!)
|
||||
(class dnsddb-options-class set-dnsddb-options-class!)
|
||||
(type dnsddb-options-type set-dnsddb-options-type!)
|
||||
(primary? dnsddb-options-primary? set-dnsddb-options-primary?!) ;;depreaced
|
||||
(file dnsddb-options-file set-dnsddb-options-file!)
|
||||
(filetype dnsddb-options-filetype set-dnsddb-options-filetype!)
|
||||
(master-name dnsddb-options-master-name set-dnsddb-options-master-name!)
|
||||
(master-ip dnsddb-options-master-ip set-dnsddb-options-master-ip!))
|
||||
|
||||
|
||||
(define (make-default-dnsddb-options)
|
||||
(really-make-dnsddb-options
|
||||
"" ;; the name of the zone
|
||||
(message-class in)
|
||||
"primary" ;;
|
||||
#t ;; is primary?
|
||||
"" ;; a filename
|
||||
"dnsd" ;; "dnsd" or "rfc"
|
||||
#f ;; Has to be set by dnsd-zones.scm, e.g. "dns01.my.example."
|
||||
#f)) ;; e.g. "192.168.2.1" or #f
|
||||
|
||||
|
||||
(define (copy-dnsddb-options options)
|
||||
(really-make-dnsddb-options
|
||||
(dnsddb-options-name options)
|
||||
(dnsddb-options-class options)
|
||||
(dnsddb-options-type options)
|
||||
(dnsddb-options-primary? options)
|
||||
(dnsddb-options-file options)
|
||||
(dnsddb-options-filetype options)
|
||||
(dnsddb-options-master-name options)
|
||||
(dnsddb-options-master-ip options)))
|
||||
|
||||
|
||||
(define (make-dnsddb-options-transformer set-option!)
|
||||
(lambda (new-value . stuff)
|
||||
(let ((new-options (if (not (null? stuff))
|
||||
(copy-dnsddb-options (car stuff))
|
||||
(make-default-dnsddb-options))))
|
||||
(set-option! new-options new-value)
|
||||
new-options)))
|
||||
|
||||
|
||||
(define with-name
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-name!))
|
||||
(define with-class
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-class!))
|
||||
(define with-type
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-type!))
|
||||
(define with-primary?
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-primary?!))
|
||||
(define with-file
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-file!))
|
||||
(define with-filetype
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-filetype!))
|
||||
(define with-master-name
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-master-name!))
|
||||
(define with-master-ip
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-master-ip!))
|
||||
|
||||
|
||||
(define (make-dnsddb-options . stuff)
|
||||
(let loop ((options (make-default-dnsddb-options))
|
||||
(stuff stuff))
|
||||
(if (null? stuff)
|
||||
options
|
||||
(let* ((transformer (car stuff))
|
||||
(value (cadr stuff)))
|
||||
(loop (transformer value options)
|
||||
(cddr stuff))))))
|
||||
|
||||
|
||||
(define (make-db-options-from-list o-list)
|
||||
(let ((options (make-default-dnsddb-options)))
|
||||
(if (eq? (car o-list) 'zone)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(let ((id (car e))
|
||||
(value (cadr e)))
|
||||
(case id
|
||||
((name)
|
||||
(if (string? value)
|
||||
(set-dnsddb-options-name!
|
||||
options (make-fqdn-name value))
|
||||
(error "Bad option argument.")))
|
||||
((type)
|
||||
(if (or (string-ci=? "primary" value)
|
||||
(string-ci=? "secondary" value)
|
||||
(string-ci=? "master" value)
|
||||
(string-ci=? "slave" value))
|
||||
(set-dnsddb-options-type! options value)
|
||||
(error "Bad option argument.")))
|
||||
((file)
|
||||
(if (and (string? value) (file-name-non-directory? value))
|
||||
(set-dnsddb-options-file! options value)
|
||||
(error "Bad option argument.")))
|
||||
((filetype)
|
||||
(if (or (string-ci=? "dnsd" value)
|
||||
(string-ci=? "rfc" value))
|
||||
(set-dnsddb-options-filetype! options value)
|
||||
(error "Bad option argument.")))
|
||||
((master-name)
|
||||
(if (string? value)
|
||||
(set-dnsddb-options-master-name! options value)
|
||||
(error "Bad option argument.")))
|
||||
((master-ip)
|
||||
(if (string? value)
|
||||
(set-dnsddb-options-master-ip! options value)
|
||||
(error "Bad option argument.")))
|
||||
(else (error "Bad option.")))))
|
||||
(cdr o-list))
|
||||
options)
|
||||
(error "Not an option list."))))
|
||||
|
|
@ -0,0 +1,103 @@
|
|||
;; Option-File for DNSD:
|
||||
;; ---------------------
|
||||
|
||||
;; Options can be reloaded using the POSIX-Signal USR1.
|
||||
|
||||
|
||||
;; External option representation <datum>:
|
||||
;; ---------------------------------------
|
||||
|
||||
;; (options
|
||||
;; [dir string]
|
||||
;; [nameservers list-of-ip-strings]
|
||||
;; [use-axfr boolean]
|
||||
;; [use-cache boolean]
|
||||
;; [cleanup-interval time-in-sec]
|
||||
;; [retry-interval time-in-sec]
|
||||
;; [use-db boolean]
|
||||
;; [use-recursion boolean]
|
||||
;; [rec-timeout time-in-s]
|
||||
;; [socket-timeout time-in-s]
|
||||
;; [socket-max-tries integer]
|
||||
;; [max-connections integer]
|
||||
;; [blacklist-time time-in-s]
|
||||
;; [blacklist-value integer]
|
||||
;; [use-pre/post boolean])
|
||||
|
||||
;; [...] indicates an optional list.
|
||||
|
||||
|
||||
;; Semantic:
|
||||
;; ---------
|
||||
|
||||
;; (dir string)
|
||||
;; Path to the directory with this configuration files.
|
||||
;; Standard value is "." - the dir where dnsd was started or the
|
||||
;; directory which was passed to (dnsd-start <optional-dir>)
|
||||
|
||||
;; (nameservers list-of-ip-strings)
|
||||
;; A list of nameserver-IPs used for recursive lookups.
|
||||
;; Standard value is a list of root-nameservers.
|
||||
|
||||
;; (use-axfr boolean)
|
||||
;; Toggles to answer to axfr-requests. Default value is #t.
|
||||
|
||||
;; (use-cache boolean)
|
||||
;; Toggles caching of responses. Default value is #t.
|
||||
|
||||
;; (cleanup-interval time-in-sec)
|
||||
;; Clean the cache and slist after X seconds. Default value is 1h.
|
||||
|
||||
;; (retry-interval time-in-sec)
|
||||
;; Minimum value in seconds to trigger zone-reloads. This can override
|
||||
;; the value of some masterfiles. Default value is 1h.
|
||||
|
||||
;; (use-db boolean boolean)
|
||||
;; Toggle the usage of the local database. Default value is on - #t.
|
||||
|
||||
;; (use-recursion boolean)
|
||||
;; Switch the recursive-lookup on/off. Default value is on - #t.
|
||||
|
||||
;; (rec-timeout time-in-sec)
|
||||
;; Global timeout for a recursive lookup. Default is 10 seconds.
|
||||
|
||||
;; (socket-timeout time-in-sec)
|
||||
;; Timeout for one lookup during a recursive lookup. Default is 2 seconds.
|
||||
|
||||
;; (socket-max-tries integer)
|
||||
;; Maximum nuber of tries to establish a connection for recursive lookups.
|
||||
;; Default value is 3.
|
||||
|
||||
;; (max-connection integer)
|
||||
;; Maximum concurrent connections for each UDP and TCP. Default is 25.
|
||||
|
||||
;; (blacklist-time time-in-sec)
|
||||
;; How long will a bad NS be blacklisted/not used? Default is 30 min.
|
||||
|
||||
;; (blacklist-value integer)
|
||||
;; How often, before a bad NS will be ignored? Default is 5 times.
|
||||
|
||||
;; (use-pre/post boolean)
|
||||
;; Toggles load of pre- and post-processing files. Default is off - #f.
|
||||
|
||||
;; all args are optional. If not given, the def. value will be used.
|
||||
|
||||
|
||||
;; Some examples:
|
||||
;; --------------
|
||||
;;
|
||||
;; (options (nameservers ("192.168.2.1" "192.168.2.2"))
|
||||
;; (use-axfr #t)
|
||||
;; (use-cache #t)
|
||||
;; (cleanup-interval 666)
|
||||
;; (use-recursion #t)
|
||||
;; (use-db #f)
|
||||
;; (use-pre/post #f))
|
||||
;;
|
||||
;; (options) == use the default values.
|
||||
;;
|
||||
|
||||
;; OPTION-DEFINITIONS:
|
||||
|
||||
(options)
|
||||
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
(lambda (msg socket-addr dnsd-options)
|
||||
(display "Postprocessing works.")
|
||||
(values msg dnsd-options))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
(lambda (msg socket-addr dnsd-options)
|
||||
(display "Preprocessing works.")
|
||||
(values msg dnsd-options))
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
;; Zones-File for DNSD:
|
||||
;; --------------------
|
||||
|
||||
;; The local zones of the NS can be reloaded using the
|
||||
;; POSIX signal USR2.
|
||||
|
||||
|
||||
;; External zones representation <datum>:
|
||||
;; --------------------------------------
|
||||
|
||||
;; zone-file ::= list-of-zone-lists
|
||||
|
||||
;; list-of-zone ::= primary-zone | secondary-zone
|
||||
|
||||
;; primary-zone ::= (zone (name string)
|
||||
;; (type "master" or "primary")
|
||||
;; (file string)
|
||||
;; [filetype string])
|
||||
|
||||
;; secondary-zone ::= (zone (name string)
|
||||
;; (type "slave" or "secondary")
|
||||
;; (master-name string)
|
||||
;; [master-ip ip-string])
|
||||
|
||||
|
||||
|
||||
;; [...] is an optional list.
|
||||
|
||||
|
||||
;; Semantic:
|
||||
;; ---------
|
||||
|
||||
;; list-of-zone-lists
|
||||
;; A list containing all zones of the NS.
|
||||
|
||||
;; list-of-zone
|
||||
;; A list containing the options for one zone of the NS.
|
||||
|
||||
;; (name string)
|
||||
;; The fully-qualified-domain-name of the zone.
|
||||
|
||||
;; (type "master" or "slave")
|
||||
;; The type of the zone. One of the two strings: "master" or "slave".
|
||||
;; Alternatively, it can be "primary" or "secondary".
|
||||
|
||||
;; (file string)
|
||||
;; The filename of the masterfile.
|
||||
|
||||
;; (filetype string)
|
||||
;; One of the two strings "dnsd" or "rfc". Default is "dnsd".
|
||||
|
||||
;; (master-name string)
|
||||
;; The domain-name of the master-nameserver.
|
||||
|
||||
;; (master-ip ip-string)
|
||||
;; The IP of the master-nameserver. If non given, DNSD will try to
|
||||
;; lookup the IP.
|
||||
|
||||
|
||||
;; Examples:
|
||||
;; --------
|
||||
|
||||
;; () == No zones given. Use dnsd as a resolver only.
|
||||
;;
|
||||
;; Try the examples and be a secondary NS for the domain "porsche.de"
|
||||
;;
|
||||
;;((zone (name "my.example.")
|
||||
;; (type "master")
|
||||
;; (file "zone-example-scheme"))
|
||||
;; (zone (name "example.com.")
|
||||
;; (type "master")
|
||||
;; (file "zone-example-rfc")
|
||||
;; (filetype "rfc")))
|
||||
;; (zone (name "porsche.de.")
|
||||
;; (type "slave")
|
||||
;; (master-name "dns01.fw.porsche.de."))
|
||||
|
||||
;; DEFINE HERE:
|
||||
|
||||
()
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
$ORIGIN example.com.
|
||||
$TTL 2D
|
||||
example.com. IN SOA gateway root.example.com. (
|
||||
2003072441 ; serial
|
||||
1D ; refresh
|
||||
2H ; retry
|
||||
1W ; expiry
|
||||
2D ) ; minimum
|
||||
|
||||
IN NS gateway
|
||||
IN MX 10 sun
|
||||
|
||||
gateway IN A 192.168.0.1
|
||||
IN A 192.168.1.1
|
||||
sun IN A 192.168.0.2
|
||||
moon IN A 192.168.0.3
|
||||
earth IN A 192.168.1.2
|
||||
mars IN A 192.168.1.3
|
||||
www IN CNAME venus
|
||||
|
||||
; A cname-loop...
|
||||
|
||||
venus IN CNAME saturn
|
||||
saturn IN CNAME venus
|
||||
|
||||
; Glue Data
|
||||
|
||||
nofreude IN NS ns1.nofreude
|
||||
|
||||
ns1.nofreude IN A 192.168.2.66
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
; Zone-example using the functions from dnsd/rr-def.scm and lib/dns.scm
|
||||
; ---------------------------------------------------------------------
|
||||
|
||||
(let ((mc (message-class in))
|
||||
(ttl (* 60 60 24)))
|
||||
(list
|
||||
(dns-rr-soa "my.example." mc ttl
|
||||
(list "nameserver.my.example." "webmaster.my.example"
|
||||
20051203 7200 600 300000 1111))
|
||||
(dns-rr-a "my.example." mc ttl "192.168.2.1")
|
||||
(dns-rr-ns "my.example." mc ttl "nameserver.my.example.")
|
||||
(dns-rr-a "on.my.example." mc ttl "192.168.2.2")
|
||||
(dns-rr-a "*.my.example." mc ttl "192.168.2.3")
|
||||
(dns-rr-mx "my.example" mc ttl (list 11 "mx.my.example"))
|
||||
(dns-rr-cname "cname.my.example" mc ttl "my.example")
|
||||
(dns-rr-a "mx.my.example" mc ttl "192.168.2.4")
|
||||
(dns-rr-ns "ns.my.example" mc ttl "ns.test.")
|
||||
(dns-rr-ns "more.my.example" mc ttl "ns2.my.example")
|
||||
(dns-rr-a "ns2.my.example" mc ttl "192.168.2.11")))
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
; ------------------------
|
||||
; --- Syslog-Interface ---
|
||||
; ------------------------
|
||||
|
||||
; Syslog/Debug-Stuff for dnsd.
|
||||
|
||||
; This file is (maybe) 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.
|
||||
|
||||
|
||||
(define *debug-info* #f) ; switch debug-information on/off
|
||||
|
||||
;; TODO: log-file instead of display-information:
|
||||
|
||||
;; Show some debug-information
|
||||
(define display-debug
|
||||
(lambda args
|
||||
(if *debug-info*
|
||||
(begin
|
||||
(display "dnsd: ")
|
||||
(map (lambda (e) (display e) (display " ")) args)
|
||||
(newline))
|
||||
#f)))
|
||||
|
||||
(define (apply-w/debug proc . args)
|
||||
(if *debug-info* (apply proc args)))
|
||||
|
||||
(define (dnsd-log log-level msg . args)
|
||||
(syslog log-level (apply format #f msg args)))
|
||||
|
|
@ -0,0 +1,369 @@
|
|||
; -------------------------
|
||||
; --- Masterfile-Parser ---
|
||||
; -------------------------
|
||||
|
||||
; Parser for Masterfiles based on the RFCs: 1034 / 1035 / 2308 and
|
||||
; the BIND-Time-Value-Format convention.
|
||||
|
||||
; 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.
|
||||
|
||||
|
||||
; Interface:
|
||||
; ----------
|
||||
|
||||
; (parse-mf fileaname dnsd-options) -> list-of-resource-records
|
||||
|
||||
|
||||
;; Lexer:
|
||||
;; ------
|
||||
|
||||
;; The lexer was generated using SILex v1.0 by Danny Dubé with
|
||||
;; specification file "masterfile.l"
|
||||
;; For more information about SILex visit: http://www.iro.umontreal.ca/~dube/
|
||||
;; TYPE: filename x dnsd-options -> list-of-lexems or #f
|
||||
(define (lex-masterfile file dnsd-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while parsing the file ~S"
|
||||
file)
|
||||
(dnsd-log (syslog-level debug)
|
||||
"Above condition is: ~A"
|
||||
condition)
|
||||
#f)
|
||||
(lambda ()
|
||||
(and-let* ((the-path (string-append (dnsd-options-dir dnsd-options) file))
|
||||
(whatever (file-name-non-directory? the-path))
|
||||
(the-port (open-input-file the-path)))
|
||||
(lexer-init 'port the-port)
|
||||
(let loop ((l '()))
|
||||
(let ((lexem (lexer)))
|
||||
(if (eq? lexem 'eof)
|
||||
(begin
|
||||
(close-input-port the-port)
|
||||
(reverse (cons lexem l)))
|
||||
(loop (cons lexem l)))))))))
|
||||
|
||||
|
||||
;; Parser:
|
||||
;; -------
|
||||
|
||||
;; Maybe append a domain-origin to a string:
|
||||
;; TYPE: dn-label-string x fqdn-string -> fqdn-string
|
||||
(define (parse-mf-maybe-append-origin name origin)
|
||||
(let ((l (string-length name)))
|
||||
(if (and (not (= 0 l)) (not (char=? #\. (string-ref name (- l 1)))))
|
||||
(if (string=? origin ".")
|
||||
(string-append name origin)
|
||||
(string-append name "." origin))
|
||||
name)))
|
||||
|
||||
|
||||
;; Parse (or restore) the name of the current line:
|
||||
;; TYPE: dn-label-string or symbol x fqdn-string x dn-label-string ->
|
||||
;; fqdn x dn-label-string
|
||||
(define (parse-mf-node-name? elem origin last-name)
|
||||
(cond
|
||||
((eq? elem 'origin-ref) (values origin origin)) ; @ in the masterfile
|
||||
((eq? elem 'blank) ; no name given - use last one
|
||||
(values (parse-mf-maybe-append-origin last-name origin) last-name))
|
||||
(else (values (parse-mf-maybe-append-origin elem origin) elem))))
|
||||
|
||||
|
||||
;; Parse the type of a rr-line:
|
||||
;; TYPE: string -> message-type
|
||||
(define (parse-mf-type? elem)
|
||||
(message-type-symbol->type (string->symbol (string-downcase elem))))
|
||||
|
||||
|
||||
;; Parse the class of a rr-line:
|
||||
;; TYPE: string -> message-class
|
||||
(define (parse-mf-class? elem)
|
||||
(message-class-symbol->type (string->symbol (string-downcase elem))))
|
||||
|
||||
|
||||
;; Parse a RFC-time value or a BIND-Masterfiles value: #w#d#h#m#s
|
||||
;; eg. 1 Week = 1w or 1d20s = 1 day and 20 seconds
|
||||
;; This algorithm is very liberal - a possible value would be 12s1d1w1s
|
||||
;; TYPE: string -> number
|
||||
(define (parse-mf-time-value? elem)
|
||||
(let loop ((str elem)
|
||||
(counter 0)
|
||||
(val 0))
|
||||
(let ((l (string-length str)))
|
||||
(if (= l 0)
|
||||
val
|
||||
(let ((sub (substring str counter (+ counter 1))))
|
||||
(if (string->number sub)
|
||||
(if (= counter (- l 1))
|
||||
(string->number str) ; original RFC format
|
||||
(loop str (+ counter 1) val))
|
||||
(let ((val2 (string->number (substring str 0 counter)))
|
||||
(rest-string (substring str (+ counter 1) l)))
|
||||
(cond
|
||||
((string-ci=? sub "w")
|
||||
(loop rest-string 0 (+ val (* 7 24 60 60 val2))))
|
||||
((string-ci=? sub "d")
|
||||
(loop rest-string 0 (+ val (* 24 60 60 val2))))
|
||||
((string-ci=? sub "h")
|
||||
(loop rest-string 0 (+ val (* 60 60 val2))))
|
||||
((string-ci=? sub "m")
|
||||
(loop rest-string 0 (+ val (* 60 val2))))
|
||||
((string-ci=? sub "s")
|
||||
(loop rest-string 0 (+ val val2)))
|
||||
(else
|
||||
(display elem)
|
||||
(error "Wrong time-value format"))))))))))
|
||||
|
||||
|
||||
;; Parse a rr-line:
|
||||
;; Syntax: {<domain>|@|<blank>} [<ttl>] [<class>] <type> <rdata>
|
||||
;; The algorithm has to guess serveral times which value actually
|
||||
;; is been parsed.
|
||||
;; TYPE: rr-line-of-lexems x fqdn x dn-string x ttl-number
|
||||
;; -> '(name ttl class type rdata origin) x fqdn x dn-string x ttl-number
|
||||
(define (parse-mf-rr line origin current-rr-name the-ttl)
|
||||
(receive
|
||||
(rr-name current-rr-name)
|
||||
(parse-mf-node-name? (car line) origin current-rr-name)
|
||||
(let* ((sec (cadr line))
|
||||
(type (parse-mf-type? sec)))
|
||||
(if type ; Parsing the type?
|
||||
(values (list rr-name the-ttl #f type (cddr line) origin)
|
||||
origin current-rr-name the-ttl)
|
||||
(let ((class (parse-mf-class? sec)))
|
||||
(if class ; Parsing a class?
|
||||
(let ((type (parse-mf-type? (caddr line))))
|
||||
(values (list rr-name the-ttl class type (cdddr line) origin)
|
||||
origin current-rr-name the-ttl))
|
||||
(let ((ttl (parse-mf-time-value? sec)))
|
||||
(if ttl ; Now it should be a TTL.
|
||||
(let* ((third (caddr line))
|
||||
(type (parse-mf-type? third)))
|
||||
(if type
|
||||
(values
|
||||
(list rr-name ttl #f type (cdddr line) origin)
|
||||
origin current-rr-name the-ttl)
|
||||
(let ((type (parse-mf-type? (cadddr line))))
|
||||
(values
|
||||
(list
|
||||
rr-name ttl (parse-mf-class? third) type
|
||||
(cdr (cdddr line)) origin)
|
||||
origin current-rr-name the-ttl))))
|
||||
(begin
|
||||
(display line)
|
||||
(error "Parsed a bad line!"))))))))))
|
||||
|
||||
|
||||
|
||||
;; Parse a masterfile-line:
|
||||
;;<line> ::= $ORIGIN <domain-name>
|
||||
;; | $INCLUDE ...
|
||||
;; | $TTL <number> (defined in RFC 2308)
|
||||
;; | <resource-record>
|
||||
;; TODO: | $GENERATE ... BIND-Version 9
|
||||
;;
|
||||
;; TYPE: mf-line x fqdn x dn-string x ttl-number x dnsd-options
|
||||
;; -> symbol or list-of-a-rr x fqdn x dn-string x ttl-number
|
||||
(define (parse-mf-line line origin current-rr-name ttl dnsd-options)
|
||||
(let ((first (car line)))
|
||||
(cond
|
||||
;; $INCLUDE
|
||||
((eq? first 'include)
|
||||
(let* ((file-name (cadr line))
|
||||
(maybe-origin (if (= (length line) 3) (caddr line) #f))
|
||||
(lexed-file (lex-masterfile file-name dnsd-options))
|
||||
(line-list (parse-mf-lex->lines lexed-file))
|
||||
(res (parse-mf-lexem-list
|
||||
line-list (if maybe-origin maybe-origin origin)
|
||||
current-rr-name #f dnsd-options)))
|
||||
(values res origin current-rr-name ttl)))
|
||||
;; $ORIGIN
|
||||
((eq? first 'origin)
|
||||
(let ((new-origin (cadr line)))
|
||||
(values 'ORIGIN
|
||||
(parse-mf-maybe-append-origin new-origin origin)
|
||||
current-rr-name ttl)))
|
||||
;; $TTL <number>
|
||||
((eq? first 'ttl)
|
||||
(let ((new-ttl (cadr line)))
|
||||
(values 'TTL origin current-rr-name (parse-mf-time-value? new-ttl))))
|
||||
;; $GENERATE ...
|
||||
((eq? first 'generate)
|
||||
(error "parse-masterfile: GENERATE is not supported."))
|
||||
; <resource-record>
|
||||
(else (parse-mf-rr line origin current-rr-name ttl)))))
|
||||
|
||||
|
||||
;; Transforms the lexer-output into a list of lines:
|
||||
;; TYPE: list-of-lexems -> list-of-lexem-lists
|
||||
(define (parse-mf-lex->lines lex-list)
|
||||
(let loop ((l lex-list)
|
||||
(line '())
|
||||
(ignore-line #f) ; Toggle comments.
|
||||
(res '()))
|
||||
(let ((first (car l)))
|
||||
(cond
|
||||
((eq? first 'eof)
|
||||
(if (null? line)
|
||||
(reverse res)
|
||||
(reverse (cons line res))))
|
||||
((eq? first 'left-par) ; Ignore line-breaks.
|
||||
(loop (cdr l) line #t res))
|
||||
((eq? first 'right-par) ; Consider line-breaks.
|
||||
(loop (cdr l) line #f res))
|
||||
((eq? first 'newline)
|
||||
(if (not ignore-line)
|
||||
(if (null? line)
|
||||
(loop (cdr l) '() ignore-line res)
|
||||
(loop (cdr l) '() ignore-line (cons line res)))
|
||||
(loop (cdr l) line ignore-line res)))
|
||||
((eq? first 'blank-newline)
|
||||
(if (not ignore-line)
|
||||
(if (null? line)
|
||||
(loop (cdr l) (list 'blank) ignore-line res)
|
||||
(loop (cdr l) (list 'blank) ignore-line (cons line res)))
|
||||
(loop (cdr l) line ignore-line res)))
|
||||
(else
|
||||
(loop (cdr l) (append line (list first)) ignore-line res))))))
|
||||
|
||||
|
||||
;; Actually create a resourc-record from the parsed rr-line:
|
||||
;; TYPE: '(name ttl class type rdata origin) -> resource-record-data
|
||||
(define (parse-mf-create-rr line)
|
||||
(let ((class (caddr line))
|
||||
(type (cadddr line)))
|
||||
(if (not (eq? (message-class in) class))
|
||||
(begin
|
||||
(display "Message-class not supported: ")
|
||||
(display class)
|
||||
(newline))
|
||||
(let ((name (car line))
|
||||
(ttl (cadr line))
|
||||
(data (list-ref line 4))
|
||||
(origin (list-ref line 5)))
|
||||
(cond
|
||||
((eq? type (message-type a))
|
||||
(dns-rr-a name class ttl (car data)))
|
||||
((eq? type (message-type ns))
|
||||
(dns-rr-ns name class ttl
|
||||
(parse-mf-maybe-append-origin (car data) origin)))
|
||||
((eq? type (message-type cname))
|
||||
(dns-rr-cname name class ttl
|
||||
(parse-mf-maybe-append-origin (car data) origin)))
|
||||
((eq? type (message-type soa))
|
||||
(and-let* ((mname (parse-mf-maybe-append-origin (car data) origin))
|
||||
(rname (parse-mf-maybe-append-origin (cadr data) origin))
|
||||
(serial (string->number (caddr data)))
|
||||
(refresh (parse-mf-time-value? (cadddr data)))
|
||||
(retry (parse-mf-time-value? (list-ref data 4)))
|
||||
(expire (parse-mf-time-value? (list-ref data 5)))
|
||||
(minimum (parse-mf-time-value? (list-ref data 6))))
|
||||
(dns-rr-soa name class ttl
|
||||
(list mname rname serial
|
||||
refresh retry expire minimum))))
|
||||
((eq? type (message-type ptr))
|
||||
(dns-rr-ptr name class ttl
|
||||
(parse-mf-maybe-append-origin (car data) origin)))
|
||||
((eq? type (message-type hinfo))
|
||||
(dns-rr-hinfo name class ttl data))
|
||||
((eq? type (message-type mx))
|
||||
(let ((pref (string->number (car data)))
|
||||
(exchange (parse-mf-maybe-append-origin (cadr data) origin)))
|
||||
(dns-rr-mx name class ttl (list pref exchange))))
|
||||
((eq? type (message-type txt))
|
||||
(dns-rr-txt name class ttl data))
|
||||
((eq? type (message-type aaaa))
|
||||
(dns-rr-aaaa name class ttl (car data)))
|
||||
(else #f))))))
|
||||
|
||||
|
||||
;; Parse the list-of-lexems and return a list of resource-records:
|
||||
;; TYPE: list-of-lexems x fqdn x dn-string x ttl-number x dnsd-options
|
||||
;; -> list-of-resource-records
|
||||
(define (parse-mf-lexem-list l origin current-rr-name ttl dnsd-options)
|
||||
(let loop ((l l)
|
||||
(res '())
|
||||
(origin origin)
|
||||
(current-rr-name current-rr-name)
|
||||
(ttl ttl))
|
||||
(if (null? l)
|
||||
res
|
||||
(receive (next-res origin current-rr-name ttl)
|
||||
(parse-mf-line (car l) origin current-rr-name ttl
|
||||
dnsd-options)
|
||||
(cond
|
||||
((or (eq? next-res 'ORIGIN)
|
||||
(eq? next-res 'TTL))
|
||||
(loop (cdr l) res origin current-rr-name ttl))
|
||||
((and (list? next-res) ; result from INCLUDE...
|
||||
(list? (car next-res)))
|
||||
(loop (cdr l) (append next-res res) origin
|
||||
current-rr-name ttl))
|
||||
(else
|
||||
(loop (cdr l) (cons next-res res) origin
|
||||
current-rr-name ttl)))))))
|
||||
|
||||
|
||||
;; Stuff for the main parser algorithm:
|
||||
;; ------------------------------------
|
||||
|
||||
;; Searches the results of parse-mf-line for a message-class
|
||||
(define (get-message-class rrlist)
|
||||
(let loop ((res rrlist))
|
||||
(if (null? res)
|
||||
#f
|
||||
(let ((class (caddr (car res))))
|
||||
(if class class
|
||||
(loop (cdr res)))))))
|
||||
|
||||
;; Set the results of parse-mf-line to a message-class...
|
||||
(define (set-message-class rrlist class)
|
||||
(map (lambda (e)
|
||||
(cons (car e) (cons (cadr e) (cons class (cdddr e)))))
|
||||
rrlist))
|
||||
|
||||
;; Searches the results of parse-mf-line for the shortest ttl
|
||||
(define (get-soa-ttl rrlist)
|
||||
(let loop ((l rrlist))
|
||||
(if (null? l)
|
||||
#f
|
||||
(let* ((rrs (car l))
|
||||
(rr-type (cadddr rrs)))
|
||||
(if (eq? (message-type soa) rr-type)
|
||||
(let* ((rdata (cadddr (cdr rrs))))
|
||||
(parse-mf-time-value? (list-ref rdata 6)))
|
||||
(loop (cdr l)))))))
|
||||
|
||||
;; Set the ttl of lines without one...
|
||||
(define (set-ttl rrlist soa-ttl)
|
||||
(map (lambda (e)
|
||||
(let ((ttl (cadr e)))
|
||||
(if (and ttl
|
||||
(< soa-ttl ttl))
|
||||
e
|
||||
(cons (car e) (cons soa-ttl (cddr e))))))
|
||||
rrlist))
|
||||
|
||||
|
||||
;; The main parser algorithm:
|
||||
;; --------------------------
|
||||
|
||||
;; Create a list of lexems and parse the lexems into resource-record-data:
|
||||
;; TYPE: string x dnsd-options -> list-of-resourec-records
|
||||
(define (parse-mf file dnsd-options)
|
||||
(and-let* ((lex-list (lex-masterfile file dnsd-options))
|
||||
(lines (parse-mf-lex->lines lex-list))
|
||||
(res (parse-mf-lexem-list lines "." "" #f dnsd-options))
|
||||
(class (get-message-class res))
|
||||
(res (set-message-class res class))
|
||||
(soa-ttl (get-soa-ttl res))
|
||||
(res (set-ttl res soa-ttl))
|
||||
(res (map (lambda (e) (parse-mf-create-rr e)) res)))
|
||||
;; Check if there is a line with an error:
|
||||
(fold-right (lambda (e l) (if (and e l) (cons e l) #f)) '() res)))
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
; --------------------
|
||||
; --- masterfile.l ---
|
||||
; --------------------
|
||||
|
||||
; A SIlex configuration file for masterfiles.
|
||||
; For more information about SILex visit: http://www.iro.umontreal.ca/~dube/
|
||||
|
||||
; 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.
|
||||
|
||||
dchars [^\n();@ ] ;; last two chars are space and tabulator
|
||||
space [ ] ;; space and tabulator
|
||||
|
||||
%%
|
||||
|
||||
{space} (yycontinue)
|
||||
\n 'newline
|
||||
\n{space} 'blank-newline
|
||||
\; (let loop ((c (yygetc)))
|
||||
(cond
|
||||
((eq? 'eof c) 'eof)
|
||||
((char=? #\newline c)
|
||||
(begin
|
||||
(yyungetc)
|
||||
(yycontinue)))
|
||||
(else (loop (yygetc)))))
|
||||
\( 'left-par
|
||||
\) 'right-par
|
||||
(\$)ORIGIN 'origin
|
||||
(\$)INCLUDE 'include
|
||||
(\$)GENERATE 'generate
|
||||
(\$)TTL 'ttl
|
||||
\@ 'origin-ref
|
||||
{dchars}* yytext
|
||||
|
||||
<<EOF>> 'eof
|
||||
<<ERROR>> (error (yygetc))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,214 @@
|
|||
; ---------------------
|
||||
; --- DNSD-Options ---
|
||||
; ---------------------
|
||||
|
||||
; Options for DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; 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.
|
||||
|
||||
; The format and style of the option procedures is the same as seen
|
||||
; in the SUNet HTTPD & FTPD - Files
|
||||
|
||||
(define-record-type dnsd-options :dnsd-options
|
||||
(really-make-dnsd-options
|
||||
port dir nameservers use-axfr use-cache cleanup-interval retry-interval
|
||||
use-db use-recursion rec-timeout socket-timeout socket-max-tries
|
||||
max-connections blacklist-time blacklist-value use-pre/post debug-mode)
|
||||
dnsd-options?
|
||||
(port dnsd-options-port set-dnsd-options-port!)
|
||||
(dir dnsd-options-dir set-dnsd-options-dir!)
|
||||
(nameservers dnsd-options-nameservers set-dnsd-options-nameservers!)
|
||||
(use-axfr dnsd-options-use-axfr? set-dnsd-options-use-axfr?!)
|
||||
(use-cache dnsd-options-use-cache? set-dnsd-options-use-cache?!)
|
||||
(cleanup-interval dnsd-options-cleanup-interval set-dnsd-options-cleanup-interval!)
|
||||
(retry-interval dnsd-options-retry-interval set-dnsd-options-retry-interval!)
|
||||
(use-db dnsd-options-use-db? set-dnsd-options-use-db?!)
|
||||
(use-recursion dnsd-options-use-recursion? set-dnsd-options-use-recursion?!)
|
||||
(rec-timeout dnsd-options-rec-timeout set-dnsd-options-rec-timeout!)
|
||||
(socket-timeout dnsd-options-socket-timeout set-dnsd-options-socket-timeout!)
|
||||
(socket-max-tries dnsd-options-socket-max-tries set-dnsd-options-socket-max-tries!)
|
||||
(max-connections dnsd-options-max-connections set-dnsd-options-max-connections!)
|
||||
(blacklist-time dnsd-options-blacklist-time set-dnsd-options-blacklist-time!)
|
||||
(blacklist-value dnsd-options-blacklist-value set-dnsd-options-blacklist-value!)
|
||||
(use-pre/post dnsd-options-use-pre/post set-dnsd-options-use-pre/post!)
|
||||
(debug-mode dnsd-options-debug-mode set-dnsd-options-debug-mode!))
|
||||
|
||||
|
||||
(define (make-default-dnsd-options)
|
||||
(really-make-dnsd-options
|
||||
53 ; Port to listen
|
||||
"./" ; Path to the zone & option files.
|
||||
'() ; Use the default SBELT-Servers
|
||||
; Example-list: (list "192.168.2.1" "193.159.170.187" "192.36.148.17")
|
||||
; or (dns-find-nameserver-list) ; SBELT-Nameserver(s) for recursion.
|
||||
#t ; Toggles sending AXFR-responses
|
||||
#t ; Toggles the use of the cache
|
||||
(* 60 60) ; Cache garbage-collect interval in seconds
|
||||
(* 60 60) ; Min. time-val (sec) to reload a zone
|
||||
#t ; If #f don't use the db.
|
||||
#t ; If #f don't use recursion.
|
||||
10 ; Timeout (sec) for recursion.
|
||||
2 ; Timeout (sec) for a query (resolver interface).
|
||||
3 ; Max. tries on a socket (resolver interface).
|
||||
25 ; Max. concurrent connections for UDP and TCP.
|
||||
(* 60 30) ; How long will a blacklist entry be valid?
|
||||
5 ; How often must a NS be bad to be ignored.
|
||||
#f ; Don't use pre- and post-processing by default.
|
||||
#f)) ; Print debug-options to syslog.
|
||||
|
||||
(define (copy-dnsd-options options)
|
||||
(really-make-dnsd-options (dnsd-options-port options)
|
||||
(dnsd-options-dir options)
|
||||
(dnsd-options-nameservers options)
|
||||
(dnsd-options-use-axfr? options)
|
||||
(dnsd-options-use-cache? options)
|
||||
(dnsd-options-cleanup-interval options)
|
||||
(dnsd-options-retry-interval options)
|
||||
(dnsd-options-use-db? options)
|
||||
(dnsd-options-use-recursion? options)
|
||||
(dnsd-options-rec-timeout options)
|
||||
(dnsd-options-socket-timeout options)
|
||||
(dnsd-options-socket-max-tries options)
|
||||
(dnsd-options-max-connections options)
|
||||
(dnsd-options-blacklist-time options)
|
||||
(dnsd-options-blacklist-value options)
|
||||
(dnsd-options-use-pre/post options)
|
||||
(dnsd-options-debug-mode options)))
|
||||
|
||||
(define (make-dnsd-options-transformer set-option!)
|
||||
(lambda (new-value . stuff)
|
||||
(let ((new-options (if (not (null? stuff))
|
||||
(copy-dnsd-options (car stuff))
|
||||
(make-default-dnsd-options))))
|
||||
(set-option! new-options new-value)
|
||||
new-options)))
|
||||
|
||||
|
||||
(define with-port
|
||||
(make-dnsd-options-transformer set-dnsd-options-port!))
|
||||
(define with-dir
|
||||
(make-dnsd-options-transformer set-dnsd-options-dir!))
|
||||
(define with-nameservers
|
||||
(make-dnsd-options-transformer set-dnsd-options-nameservers!))
|
||||
(define with-axfr
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-axfr?!))
|
||||
(define with-cache
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-cache?!))
|
||||
(define with-cleanup-interval
|
||||
(make-dnsd-options-transformer set-dnsd-options-cleanup-interval!))
|
||||
(define with-retry-interval
|
||||
(make-dnsd-options-transformer set-dnsd-options-retry-interval!))
|
||||
(define with-db
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-db?!))
|
||||
(define with-recursion
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-recursion?!))
|
||||
(define with-rec-timeout
|
||||
(make-dnsd-options-transformer set-dnsd-options-rec-timeout!))
|
||||
(define with-socket-timeout
|
||||
(make-dnsd-options-transformer set-dnsd-options-socket-timeout!))
|
||||
(define with-socket-max-tries
|
||||
(make-dnsd-options-transformer set-dnsd-options-socket-max-tries!))
|
||||
(define with-max-connections
|
||||
(make-dnsd-options-transformer set-dnsd-options-max-connections!))
|
||||
(define with-blacklist-time
|
||||
(make-dnsd-options-transformer set-dnsd-options-blacklist-time!))
|
||||
(define with-blacklist-value
|
||||
(make-dnsd-options-transformer set-dnsd-options-blacklist-value!))
|
||||
(define with-use-pre/post
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-pre/post!))
|
||||
(define with-debug-mode
|
||||
(make-dnsd-options-transformer set-dnsd-options-debug-mode!))
|
||||
|
||||
(define (make-dnsd-options . stuff)
|
||||
(let loop ((options (make-default-dnsd-options))
|
||||
(stuff stuff))
|
||||
(if (null? stuff)
|
||||
options
|
||||
(let* ((transformer (car stuff))
|
||||
(value (cadr stuff)))
|
||||
(loop (transformer value options)
|
||||
(cddr stuff))))))
|
||||
|
||||
(define (make-options-from-list o-list options)
|
||||
(if (eq? (car o-list) 'options)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(let ((id (car e))
|
||||
(value (cadr e)))
|
||||
(case id
|
||||
((dir)
|
||||
(if (string? value)
|
||||
(set-dnsd-options-dir! options value)
|
||||
(error "Bad option argument.")))
|
||||
((nameservers)
|
||||
(if (list? value)
|
||||
(set-dnsd-options-nameservers! options value)
|
||||
(error "Bad option argument.")))
|
||||
((use-axfr)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-axfr?! options value)
|
||||
(error "Bad option argument.")))
|
||||
((use-cache)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-cache?! options value)
|
||||
(error "Bad option argument.")))
|
||||
((cleanup-interval)
|
||||
(if (and (number? value) (<= 10 value))
|
||||
(set-dnsd-options-cleanup-interval! options value)
|
||||
(error "Bad option argument.")))
|
||||
((retry-interval)
|
||||
(if (and (number? value) (<= 10 value))
|
||||
(set-dnsd-options-retry-interval! options value)
|
||||
(error "Bad option argument.")))
|
||||
((use-db)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-db?! options value)
|
||||
(error "Bad option argument.")))
|
||||
((use-recursion)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-recursion?! options value)
|
||||
(error "Bad option argument.")))
|
||||
((rec-timeout)
|
||||
(if (and (number? value) (<= 1 value))
|
||||
(set-dnsd-options-rec-timeout! options value)
|
||||
(error "Bad options argument.")))
|
||||
((socket-timeout)
|
||||
(if (and (number? value) (<= 1 value) (> 13 value))
|
||||
(set-dnsd-options-socket-timeout! options value)
|
||||
(error "Bad options argument.")))
|
||||
((socket-max-tries)
|
||||
(if (and (number? value) (<= 1 value) (> 13 value))
|
||||
(set-dnsd-options-socket-max-tries! options value)
|
||||
(error "Bad options argument.")))
|
||||
((max-connections)
|
||||
(if (and (number? value) (<= 1 value))
|
||||
(set-dnsd-options-max-connections! options value)
|
||||
(error "Bad options argument.")))
|
||||
((blacklist-time)
|
||||
(if (and (number? value) (<= 60 value))
|
||||
(set-dnsd-options-blacklist-time! options value)
|
||||
(error "Bad options argument.")))
|
||||
((blacklist-value)
|
||||
(if (and (number? value) (<= 1 value))
|
||||
(set-dnsd-options-blacklist-value! options value)
|
||||
(error "Bad options argument.")))
|
||||
((use-pre/post)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-pre/post! options value)
|
||||
(error "Bad options argument.")))
|
||||
((debug-mode)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-debug-mode! options value)
|
||||
(error "Bad options argument.")))
|
||||
(else (error "Bad option.")))))
|
||||
(cdr o-list))
|
||||
options)
|
||||
(error "Not an option list.")))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,753 @@
|
|||
; ----------------
|
||||
; --- Resolver ---
|
||||
; ----------------
|
||||
|
||||
; A DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; 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.
|
||||
|
||||
; Interface:
|
||||
; ----------
|
||||
|
||||
;(dnsd-ask-resolver-rec message protocol dnsd-options)
|
||||
|
||||
;(dnsd-ask-resolver-direct message list-of-nameservers protocol dnsd-options)
|
||||
|
||||
|
||||
;; The modified send-receive-message socket-interface from dns.scm:
|
||||
;; ----------------------------------------------------------------
|
||||
|
||||
;; Delete the given element(s) from the list:
|
||||
;; TYPE: list x list -> list
|
||||
(define (delete-list elems list)
|
||||
(cond
|
||||
((null? elems) list)
|
||||
((null? list) '())
|
||||
(else (delete-list (cdr elems) (delete (car elems) list)))))
|
||||
|
||||
|
||||
;; dnsd wants the message, not the dns-error codes.
|
||||
(define (dnsd-acceptable? reply query)
|
||||
(if (not (= (header-id (message-header reply))
|
||||
(header-id (message-header query))))
|
||||
(error "send-receive-message: Bad reply-ID from server.")))
|
||||
|
||||
|
||||
(define (dnsd-send-receive-message-tcp nameserver query dnsd-options)
|
||||
(send-receive-message-tcp-int nameserver query dnsd-acceptable? dnsd-options))
|
||||
|
||||
(define (send-receive-message-tcp-int nameservers query accept? dnsd-options)
|
||||
(receive
|
||||
(reply hit-ns other-nss)
|
||||
(let* ((sockets (map (lambda (nameserver)
|
||||
(let ((sock (create-socket protocol-family/internet
|
||||
socket-type/stream))
|
||||
(addr (internet-address->socket-address
|
||||
nameserver 53)))
|
||||
;; Ignore return value and select unconditionally later
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline) #f)
|
||||
(lambda ()
|
||||
(connect-socket-no-wait sock addr) sock))))
|
||||
nameservers))
|
||||
(nameservers (let loop ((sockets sockets)
|
||||
(nss nameservers))
|
||||
(cond
|
||||
((or (null? sockets) (null? nss)) '())
|
||||
((socket? (car sockets))
|
||||
(cons (car nss) (loop (cdr sockets) (cdr nss))))
|
||||
(else (loop (cdr sockets) (cdr nss))))))
|
||||
(sockets (filter socket? sockets))
|
||||
(ws (map socket:outport sockets))
|
||||
(wport-nameserver-alist (map cons ws nameservers))
|
||||
(wport-socket-alist (map cons ws sockets)))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(for-each close-socket sockets)
|
||||
decline)
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () 'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(let loop-port-channels ((tried-channels '())
|
||||
(number-tries 1))
|
||||
;; No channels left to try?
|
||||
(if (or (null? (delete-list tried-channels ws))
|
||||
(= (length tried-channels) (length ws))
|
||||
(>= number-tries
|
||||
(dnsd-options-socket-max-tries dnsd-options)))
|
||||
(values query #f nameservers)
|
||||
(let ((ready
|
||||
(apply select-ports
|
||||
(dnsd-options-socket-timeout dnsd-options)
|
||||
ws)))
|
||||
(let loop-ready-channels ((ready-channels ready))
|
||||
(if (null? ready-channels)
|
||||
(loop-port-channels (append tried-channels ready)
|
||||
(+ number-tries 1))
|
||||
(let* ((w (car ready-channels))
|
||||
(hit-ns
|
||||
(cdr (assoc w wport-nameserver-alist)))
|
||||
(sock (cdr (assoc w wport-socket-alist))))
|
||||
(if (not (connect-socket-successful? sock))
|
||||
(loop-ready-channels (cdr ready-channels))
|
||||
(let ((query-string (list->string
|
||||
(add-size-tag
|
||||
(message-source query))))
|
||||
(r (socket:inport sock)))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(loop-ready-channels (cdr ready-channels)))
|
||||
(lambda ()
|
||||
(display query-string w)
|
||||
(force-output w)
|
||||
(let ((a (read-char r))
|
||||
(b (read-char r)))
|
||||
(let ((len (octet-pair->number a b)))
|
||||
(let ((s (read-string len r)))
|
||||
(if (and (not (= 0 (string-length s)))
|
||||
(not (= len (string-length s))))
|
||||
(error 'unexpected-eof-from-server))
|
||||
(values (parse (string->list s)) hit-ns
|
||||
(delete hit-ns nameservers))))))))))))))))
|
||||
(lambda () (for-each close-socket sockets))))))
|
||||
(accept? reply query)
|
||||
(values reply hit-ns other-nss)))
|
||||
|
||||
|
||||
(define (dnsd-send-receive-message-udp nameserver query dnsd-options)
|
||||
(send-receive-message-udp-int nameserver query dnsd-acceptable? dnsd-options))
|
||||
|
||||
|
||||
(define (send-receive-message-udp-int nameservers query accept? dnsd-options)
|
||||
(receive
|
||||
(reply hit-ns other-nss)
|
||||
(let* ((sockets (map (lambda (nameserver)
|
||||
(let ((sock (create-socket protocol-family/internet
|
||||
socket-type/datagram))
|
||||
(addr (internet-address->socket-address
|
||||
nameserver 53)))
|
||||
(connect-socket sock addr)
|
||||
sock))
|
||||
nameservers))
|
||||
(rs (map socket:inport sockets))
|
||||
(ws (map socket:outport sockets)))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(for-each close-socket sockets)
|
||||
decline)
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () 'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(let ((query-string (list->string (message-source query)))
|
||||
(rsv (list->vector rs))
|
||||
(rport-nameserver-alist (map cons rs nameservers))
|
||||
(rport-socket-alist (map cons rs sockets)))
|
||||
(for-each (lambda (w) (display query-string w)) ws)
|
||||
(for-each force-output ws)
|
||||
(let loop-port-channels ((tried-channels '())
|
||||
(number-tries 1))
|
||||
(let ((rs-new (delete-list tried-channels rs)))
|
||||
(if (or (null? rs-new)
|
||||
(>= number-tries (dnsd-options-socket-max-tries dnsd-options))
|
||||
(= (length tried-channels) (length rs)))
|
||||
(values query #f nameservers)
|
||||
(let ((ready (apply select-ports
|
||||
(dnsd-options-socket-timeout dnsd-options)
|
||||
rs-new)))
|
||||
(let loop-ready-channels ((ready-channels ready))
|
||||
(if (null? ready-channels)
|
||||
(loop-port-channels (append tried-channels ready)
|
||||
(+ number-tries 1))
|
||||
(let* ((r (car ready-channels))
|
||||
(hit-ns (cdr (assoc r rport-nameserver-alist))))
|
||||
(if (not (connect-socket-successful?
|
||||
(cdr (assoc r rport-socket-alist))))
|
||||
(loop-ready-channels (cdr ready-channels))
|
||||
;; 512 is the maximum udp-message size:
|
||||
(let ((answer (string->list (read-string/partial 512 r))))
|
||||
(if (null? answer)
|
||||
(loop-ready-channels (cdr ready-channels))
|
||||
(values (parse answer) hit-ns
|
||||
(delete hit-ns nameservers))))))))))))))
|
||||
(lambda () (for-each close-socket sockets))))))
|
||||
(accept? reply query)
|
||||
(if (flags-truncated? (header-flags (message-header reply)))
|
||||
(send-receive-message-tcp-int nameservers query accept?)
|
||||
(values reply hit-ns other-nss))))
|
||||
|
||||
|
||||
(define (dnsd-send-receive-message nameservers query protocol dnsd-options)
|
||||
((cond
|
||||
((eq? protocol (network-protocol tcp)) dnsd-send-receive-message-tcp)
|
||||
((eq? protocol (network-protocol udp)) dnsd-send-receive-message-udp))
|
||||
nameservers query dnsd-options))
|
||||
|
||||
|
||||
;; Stuff:
|
||||
;; ------
|
||||
|
||||
; Filter a list of rrs of the given type:
|
||||
; TYPE: list-of-rrs -> list-of-rrs
|
||||
(define (filter-rr-type type list)
|
||||
(filter (lambda (e) (eq? (resource-record-type e) type)) list))
|
||||
|
||||
|
||||
;; Randomize a list (needs srfi-1 & srfi-27):
|
||||
;; TYPE: list -> list
|
||||
(define (shake-list l)
|
||||
(define (shake-list-int l res)
|
||||
(if (null? l)
|
||||
res
|
||||
(let ((random-value (random-integer (length l))))
|
||||
(shake-list-int
|
||||
(append (take l random-value) (drop l (+ 1 random-value)))
|
||||
(cons (list-ref l random-value) res)))))
|
||||
(shake-list-int l '()))
|
||||
|
||||
|
||||
|
||||
;; Check a message for its response-code:
|
||||
;; --------------------------------------
|
||||
|
||||
;; RCODE-0-Message? (Error-Free)
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-0-reply? msg)
|
||||
(eq? 'dns-no-error (flags-response-code (header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; RCODE-3-Message? (Name-Error (does not exist))
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-3-reply? msg)
|
||||
(eq? 'dns-name-error (flags-response-code
|
||||
(header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; RCODE-2-Message? Server-Failure
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-2-reply? msg)
|
||||
(eq? 'dns-server-failure (flags-response-code
|
||||
(header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; RCODE-4-Message? Not Implemented
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-4-reply? msg)
|
||||
(eq? 'dns-not-implemented (flags-response-code
|
||||
(header-flags (message-header msg)))))
|
||||
|
||||
;; RCODE-5-Message? (Refused to answer query.)
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-5-reply? msg)
|
||||
(eq? 'dns-refused (flags-response-code (header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; Are there just CNAMEs in the answer-section of a reply?
|
||||
;; TYPE message -> boolean
|
||||
(define (cname-answer? msg)
|
||||
(let ((cnames (fold-right
|
||||
(lambda (e b)
|
||||
(or (eq? (message-type cname) (resource-record-type e)) b))
|
||||
#f (message-answers msg)))
|
||||
(other (fold-right
|
||||
(lambda (e b)
|
||||
(or (not (eq? (message-type cname)
|
||||
(resource-record-type e))) b))
|
||||
#f (message-answers msg))))
|
||||
(if other #f cnames)))
|
||||
|
||||
|
||||
;; Interpreting the results of dbi-lookup-rec - Zone found, but not the name.
|
||||
;; TYPE res-list-of-db-lookup-rec -> boolean
|
||||
(define (no-entry? res-l)
|
||||
(and (null? (car res-l)) (null? (cadr res-l))
|
||||
(null? (caddr res-l)) (cadddr res-l)))
|
||||
|
||||
|
||||
;; Is the query a cname-question?
|
||||
;; TYPE: message -> boolean
|
||||
(define (cname-question? msg)
|
||||
(eq? (message-type cname) (question-type (car (message-questions msg)))))
|
||||
|
||||
|
||||
;; Create a reply from the internally found (db or cache) information.
|
||||
;; NOTE: This function is part of the exported functions.
|
||||
;; TYPE: message x res-list-of-db-lookup-rec x dnsd-options -> message
|
||||
(define (make-response message r-list dnsd-options)
|
||||
(let* ((use-recursion? (dnsd-options-use-recursion? dnsd-options))
|
||||
(error-code (if (no-entry? r-list) 'dns-name-error 'dns-no-error))
|
||||
(msg-header (message-header message))
|
||||
(msg-flags (header-flags msg-header))
|
||||
(anli (car r-list))
|
||||
(auli (cadr r-list))
|
||||
(adli (caddr r-list))
|
||||
(aufl (cadddr r-list)))
|
||||
(make-message
|
||||
(make-header (header-id msg-header)
|
||||
(make-flags
|
||||
'response
|
||||
(flags-opcode msg-flags)
|
||||
aufl
|
||||
(flags-truncated? msg-flags)
|
||||
(flags-recursion-desired? msg-flags)
|
||||
use-recursion?
|
||||
(flags-zero msg-flags)
|
||||
error-code)
|
||||
(header-question-count msg-header)
|
||||
(length anli)
|
||||
(length auli)
|
||||
(length adli))
|
||||
(message-questions message)
|
||||
anli auli adli '())))
|
||||
|
||||
|
||||
;; Increment the answer-section (for adding a cname)
|
||||
;; TYPE: message -> message
|
||||
(define (msg-inc-answers msg-header)
|
||||
(let ((msg-flags (header-flags msg-header)))
|
||||
(make-header (header-id msg-header)
|
||||
msg-flags
|
||||
(header-question-count msg-header)
|
||||
(+ 1 (header-answer-count msg-header))
|
||||
(header-nameserver-count msg-header)
|
||||
(header-additional-count msg-header))))
|
||||
|
||||
|
||||
;; Change the type of a question to (message-type cname)
|
||||
;; TYPE: messag -> message
|
||||
(define (msg->cname-msg msg)
|
||||
(let ((q (car (message-questions msg))))
|
||||
(make-message (message-header msg)
|
||||
(list (make-question (question-name q)
|
||||
(message-type cname)
|
||||
(question-class q)))
|
||||
(message-answers msg)
|
||||
(message-nameservers msg)
|
||||
(message-additionals msg) '())))
|
||||
|
||||
|
||||
;; Assignment procs:
|
||||
;; -----------------
|
||||
|
||||
;; Set the recursion-aviable flag:
|
||||
;; TYPE: message x boolean -> message
|
||||
(define (msg-set-recursion-aviable! msg bool)
|
||||
(set-flags-recursion-available! (header-flags (message-header msg)) bool))
|
||||
|
||||
|
||||
;; Set the response-code of a message:
|
||||
;; NOTE: This function is part of the exported functions.
|
||||
;; TYPE: message x rcode -> message
|
||||
(define (msg-set-rcode! msg code)
|
||||
(let ((rcode (case code
|
||||
((0) 'dns-no-error)
|
||||
((1) 'dns-format-error)
|
||||
((2) 'dns-server-failure)
|
||||
((3) 'dns-name-error)
|
||||
((4) 'dns-not-implemented)
|
||||
((5) 'dns-refused)
|
||||
(else code))))
|
||||
(set-flags-response-code! (header-flags (message-header msg)) rcode)))
|
||||
|
||||
|
||||
;; Direct lookup:
|
||||
;; --------------
|
||||
|
||||
;; Direct lookup of a query asking the given Nameserves:
|
||||
;; TYPE: message x list-of-address32 tcp/udp x dnsd-options -> message
|
||||
(define (dnsd-lookup-direct msg ns-list proto dnsd-options)
|
||||
(receive (msg hit-ip other-ips)
|
||||
(dnsd-send-receive-message
|
||||
ns-list
|
||||
(make-message (message-header msg) (message-questions msg)
|
||||
(message-answers msg) (message-nameservers msg)
|
||||
(message-additionals msg) (mc-message->octets msg))
|
||||
proto dnsd-options)
|
||||
(if hit-ip
|
||||
msg
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"dnsd-direct-lookup. Nameservers ~S not reachable."
|
||||
ns-list)
|
||||
(error "dnsd-direct-lookup. No NS reachable.")))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; Stuff for recursive lookup:
|
||||
;; ---------------------------
|
||||
|
||||
|
||||
;; SBELT:
|
||||
;; ------
|
||||
|
||||
;; Fallback nameserver for recursive lookup. This is the default value which
|
||||
;; can be changed by the dnsd-options:
|
||||
(define *sbelt*
|
||||
(list ;(ip-string->address32 "192.5.5.241")
|
||||
(ip-string->address32 "192.36.148.17")
|
||||
(ip-string->address32 "192.5.5.241")))
|
||||
|
||||
|
||||
;; Some nameserver IPs:
|
||||
;; --------------------
|
||||
|
||||
;; 192.36.148.17 i.root-servers.net. (for .)
|
||||
;; 192.5.5.241 f.root-server.net. (for .)
|
||||
|
||||
;; 192.5.6.30 A.GTLD-SERVERS.NET. (for .com.
|
||||
;; 193.159.170.187 deNIC-NS (for .de.)
|
||||
|
||||
|
||||
;; Record-Type for additional information needed by the lookup:
|
||||
;; cnames is a list of all seen CNAMES to avoid CNAME-loops.
|
||||
;; ips is a list of used NS-IPs for the query.
|
||||
;; timestamp is the creation-time of the context and used for timeouts.
|
||||
(define-record-type context :context
|
||||
(really-make-context cnames ips timestamp)
|
||||
context?
|
||||
(cnames get-context-cnames set-context-cnames!)
|
||||
(ips get-context-ips set-context-ips!)
|
||||
(timestamp get-context-timestamp))
|
||||
|
||||
|
||||
;; Makes the lookup-context for a given query.
|
||||
;; TYPE: message -> context
|
||||
(define (make-context message)
|
||||
(really-make-context
|
||||
(list (question-name (car (message-questions message))))
|
||||
'()
|
||||
(time)))
|
||||
|
||||
;; Add a name to the context.
|
||||
;; TYPE: context x string -> context
|
||||
(define (update-context-cnames! context value)
|
||||
(set-context-cnames! context (cons value (get-context-cnames context)))
|
||||
context)
|
||||
|
||||
;; Add a IP to the context.
|
||||
;; TYPE: context x address32 -> context
|
||||
(define (update-context-ips! context value)
|
||||
(set-context-ips! context (cons value (get-context-ips context)))
|
||||
context)
|
||||
|
||||
|
||||
;; Search the SLIST for the best 'nearest' nameserver to query for a message.
|
||||
;; The nearest server is the server for the domain with the most matching labels
|
||||
;; seen from the root: 1) www.example.com. 2) example.com. 3) com. 4) . 5) SBELT
|
||||
;; TYPE: message x dnsd-options -> list-of-nameserver-ips x zone-name-of-ns
|
||||
(define (search-for-ns-ips msg dnsd-options)
|
||||
(let* ((q (car (message-questions msg)))
|
||||
(name (question-name q))
|
||||
(class (question-class q)))
|
||||
(let loop ((name name))
|
||||
(let ((ip-list (dnsd-slist-lookup
|
||||
(make-simple-query-message name (message-type ns) class)
|
||||
dnsd-options)))
|
||||
(if ip-list
|
||||
(values ip-list name #f)
|
||||
(if (string=? "." name)
|
||||
(let* ((sbelt-string (dnsd-options-nameservers dnsd-options))
|
||||
(sbelt (map ip-string->address32 sbelt-string)))
|
||||
(if (null? sbelt)
|
||||
(values *sbelt* name #t)
|
||||
(values sbelt name #t)))
|
||||
(loop (cut-name name))))))))
|
||||
|
||||
|
||||
;; Ask the message to some NS from the SLIST. Keep track which NSs were already
|
||||
;; contacted for the given query in 'context'.
|
||||
;; TYPE: message x udp/tcp x dnsd-options x context
|
||||
;; -> message-answer x context x nearest-NS-string x address32
|
||||
(define (ask-nameservers msg protocol dnsd-options context)
|
||||
(receive
|
||||
(ip-list name sbelt?)
|
||||
(search-for-ns-ips msg dnsd-options)
|
||||
;; Use only IPs which haven't been tried jet
|
||||
(let ((good-ips (filter (lambda (e)
|
||||
(not (fold-right
|
||||
(lambda (e1 b)
|
||||
(or b (= e1 e)))
|
||||
#f (get-context-ips context))))
|
||||
ip-list)))
|
||||
;; randomize the list for some simple load-balancing...
|
||||
(let loop ((good-ips (shake-list good-ips)))
|
||||
(if (null? good-ips)
|
||||
(error "ask-nameservers: Tried all known Nameservers.")
|
||||
(receive
|
||||
(msg hit-ip other-ips)
|
||||
(dnsd-send-receive-message
|
||||
(list (car good-ips))
|
||||
(make-message (message-header msg) (message-questions msg)
|
||||
(message-answers msg) (message-nameservers msg)
|
||||
(message-additionals msg) (mc-message->octets msg))
|
||||
protocol dnsd-options)
|
||||
(if hit-ip
|
||||
(values msg (update-context-ips! context hit-ip)
|
||||
name hit-ip)
|
||||
(begin
|
||||
(if (not sbelt?) (dnsd-blacklist! (car good-ips)))
|
||||
(loop (cdr good-ips))))))))))
|
||||
|
||||
|
||||
|
||||
;; Some responses contain nameserver-names but sadly not their IPs.
|
||||
;; This function searches for those IPs, add the results to the
|
||||
;; cache and restarts the recursive lookup.
|
||||
;; TYPE: message x udp/tcp x list-of-rrs x dnsd-options -> unspecific
|
||||
(define (lookup-nameserver-ips msg protocol ns-rrs dnsd-options)
|
||||
(let* ((ns-names (map (lambda (e) (resource-record-data-ns-name
|
||||
(resource-record-data e))) ns-rrs))
|
||||
(ns-queries (map (lambda (e)
|
||||
;;(display-debug "Looking for this names: " e)
|
||||
(make-simple-query-message
|
||||
e (message-type a)
|
||||
(question-class
|
||||
(car (message-questions msg))))) ns-names))
|
||||
; ;; This step might take a while :-(
|
||||
; (answers (map (lambda (e)
|
||||
; (dnsd-ask-resolver-rec e protocol dnsd-options))
|
||||
; ns-queries))
|
||||
;; Concurrent lookup of the IPs:
|
||||
(ch-list (map
|
||||
(lambda (msg)
|
||||
(let ((ch-res (make-channel)))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(sync (send-rv
|
||||
ch-res
|
||||
;; Use dnsd-ask-r... because of the 'good'
|
||||
;; return value.
|
||||
(dnsd-ask-resolver-rec msg protocol
|
||||
dnsd-options)))))
|
||||
ch-res))
|
||||
ns-queries))
|
||||
;; Wait for all results:
|
||||
(answers (map (lambda (ch) (sync (receive-rv ch))) ch-list))
|
||||
(good-answers (filter (lambda (e) (rcode-0-reply? e)) answers))
|
||||
(ip-rrs (map (lambda (msg) (filter-rr-type (message-type a)
|
||||
(message-answers msg)))
|
||||
good-answers))
|
||||
(flat-ns-list (fold-right (lambda (e l) (append e l)) '() ip-rrs)))
|
||||
(if (null? flat-ns-list)
|
||||
#f ;TODO: Do we need a strategy to avoid loops if we don't find NS?
|
||||
(dnsd-slist-update!
|
||||
(make-message (message-header msg) (message-questions msg)
|
||||
'() ns-rrs flat-ns-list '())))))
|
||||
|
||||
|
||||
;; Restart dnsd-get-info-int with question-name changed to the cname.
|
||||
;; TYPE: query-message x response-message x udp/tcp x dnsd-options x context
|
||||
;; -> respones-message
|
||||
(define (cname-lookup msg res protocol dnsd-options context)
|
||||
(let* ((q (car (message-questions msg)))
|
||||
(msg-name (question-name q))
|
||||
(cname-rr (fold-right
|
||||
(lambda (e a)
|
||||
(if a a
|
||||
(if (and (eq? (message-type cname)
|
||||
(resource-record-type e))
|
||||
(string-ci=? (resource-record-name e)
|
||||
msg-name))
|
||||
e a)))
|
||||
#f (message-answers res)))
|
||||
(cname (resource-record-data-cname-name
|
||||
(resource-record-data cname-rr)))
|
||||
(found-loop? (fold-right (lambda (e b)
|
||||
(or (string-ci=? cname e) b))
|
||||
#f (get-context-cnames context))))
|
||||
(if found-loop? ; Check for CNAME-Loop
|
||||
(begin ;;(display-debug "Found a CNAME-loop. Aborting!")
|
||||
(error "Found a CNAME-loop. Aborting recursive lookup."))
|
||||
(let* ((new-msg (make-message (message-header msg)
|
||||
(list (make-question cname
|
||||
(question-type q)
|
||||
(question-class q)))
|
||||
'() '() '() '()))
|
||||
(res (dnsd-get-info-int new-msg protocol dnsd-options
|
||||
;; Keep timout, allow all IPs again...
|
||||
(really-make-context
|
||||
(cons cname (get-context-cnames context))
|
||||
'()
|
||||
(get-context-timestamp context))))
|
||||
(new-res (make-message (msg-inc-answers (message-header res))
|
||||
(message-questions msg)
|
||||
(cons cname-rr (message-answers res))
|
||||
(message-nameservers res)
|
||||
(message-additionals res) '())))
|
||||
new-res))))
|
||||
|
||||
|
||||
|
||||
;; Recursive Lookup as seen in RFC 1034:
|
||||
;; -------------------------------------
|
||||
|
||||
;; 1) Check local information and (if present) return it to the client.
|
||||
;; 2) Search for server(s) to ask. Wait for a response.
|
||||
;; 3) Analyze the response:
|
||||
;; 3.1 cache answers or name error.
|
||||
;; 3.2 cache delegation info to other servers. Retry.
|
||||
;; 3.3 if the response shows a CNAME and that is not the
|
||||
;; answer itself, cache the CNAME, change the SNAME to the
|
||||
;; canonical name in the CNAME RR and go to step 1.
|
||||
;; 3.4 servers failure etc.: delete server from cache. Retry.
|
||||
|
||||
|
||||
;; Start the recursive lookup and initialize the first context-list
|
||||
;; with the name of the question (to avoid CNAME-Loops).
|
||||
;; TYPE: message x udp/tcp x dnsd-options -> message
|
||||
(define (dnsd-get-information message protocol dnsd-options)
|
||||
(dnsd-get-info-int message protocol dnsd-options (make-context message)))
|
||||
|
||||
|
||||
;; TYPE: message x udp/tcp x dnsd-options x context -> message
|
||||
(define (dnsd-get-info-int message protocol dnsd-options context)
|
||||
; 1) Search local information:
|
||||
(let* ((use-cache? (dnsd-options-use-cache? dnsd-options))
|
||||
(local-res (if use-cache? (dnsd-cache-lookup? message) #f)))
|
||||
;; Timeout?
|
||||
(if (> (- (time) (get-context-timestamp context))
|
||||
(dnsd-options-rec-timeout dnsd-options))
|
||||
(error "dnsd-get-info-int: Global timeout.")
|
||||
(if local-res (make-response message local-res dnsd-options)
|
||||
;; 2) Could be: Search for the best nameserver to ask.
|
||||
;; Now it's: Ask all servers concurrent and take
|
||||
;; the first result.
|
||||
(receive
|
||||
(rec-res context followed-name hit-ip)
|
||||
(ask-nameservers message protocol dnsd-options context)
|
||||
;; 3) Analyze the response:
|
||||
(let* ((ns-rrs (filter-rr-type (message-type ns)
|
||||
(message-nameservers rec-res)))
|
||||
(a-rrs (filter-rr-type (message-type a)
|
||||
(message-additionals rec-res))))
|
||||
(cond
|
||||
;; 3.4) Bad answer: Some NS are to 'lazy' to return cnames
|
||||
;; and return RCODE 5 instead. The NS of sourceforge.net.
|
||||
;; are a good bad example.
|
||||
((rcode-5-reply? rec-res)
|
||||
(if (not (cname-question? rec-res))
|
||||
(let ((cname-query
|
||||
(dnsd-get-information (msg->cname-msg message)
|
||||
protocol dnsd-options)))
|
||||
(if (cname-answer? cname-query)
|
||||
(cname-lookup message cname-query protocol
|
||||
dnsd-options context)
|
||||
(begin (dnsd-blacklist! hit-ip)
|
||||
rec-res)))
|
||||
(begin (dnsd-blacklist! hit-ip) rec-res)))
|
||||
;; 3.4) Try again with other servers.
|
||||
((rcode-2-reply? rec-res)
|
||||
(dnsd-blacklist! hit-ip)
|
||||
(dnsd-get-info-int message protocol dnsd-options context))
|
||||
((rcode-4-reply? rec-res)
|
||||
(dnsd-blacklist! hit-ip
|
||||
(dnsd-options-blacklist-value dnsd-options))
|
||||
(dnsd-get-info-int message protocol dnsd-options context))
|
||||
(else
|
||||
;; A "good" reply.
|
||||
(dnsd-blacklist-unlist! hit-ip dnsd-options)
|
||||
(cond
|
||||
;; 3.1) Found a name-error.
|
||||
((rcode-3-reply? rec-res)
|
||||
(dnsd-cache-update! rec-res) rec-res)
|
||||
;; 3.4) Whatever error is left... .
|
||||
((not (rcode-0-reply? rec-res)) rec-res)
|
||||
;; 3.1) Found an answer.
|
||||
((not (null? (message-answers rec-res)))
|
||||
;; 3.3) CNAME?
|
||||
(if (and (not (cname-question? rec-res))
|
||||
(cname-answer? rec-res))
|
||||
(begin
|
||||
(dnsd-cache-update! (msg->cname-msg rec-res))
|
||||
;;(display-debug "Starting CNAME Lookup!")
|
||||
(cname-lookup message rec-res protocol
|
||||
dnsd-options context))
|
||||
;; Returning of not-authoritative data
|
||||
;; may be a bad habbit...
|
||||
(if (flags-authoritative?
|
||||
(header-flags (message-header rec-res)))
|
||||
rec-res
|
||||
rec-res)))
|
||||
(else
|
||||
;; 3.2) Redirection to other Nameservers?
|
||||
(cond
|
||||
((null? ns-rrs) rec-res)
|
||||
((null? a-rrs)
|
||||
;; Only nameserver resource-records, search for IPs
|
||||
(lookup-nameserver-ips rec-res protocol
|
||||
ns-rrs dnsd-options)
|
||||
(dnsd-get-info-int message protocol dnsd-options context))
|
||||
(else
|
||||
(dnsd-slist-update! rec-res)
|
||||
(dnsd-get-info-int message protocol
|
||||
dnsd-options context)))))))))))))
|
||||
|
||||
|
||||
|
||||
;; ---------------------------------
|
||||
;; --- Server/Resolver-Interface ---
|
||||
;; ---------------------------------
|
||||
|
||||
;; (dnsd-ask-resolver-direct msg nameserver-list protocol dnsd-options)
|
||||
;; - Ask a specific nameserver (& don't use the SLIST-Interface.)
|
||||
;; (E.g. for the AXFR-Update algorihms.)
|
||||
;;
|
||||
;; (dnsd-ask-resolver-rec msg protocol dnsd-options)
|
||||
;; - Ask indirect (and recursive) via the SLIST-Cache.
|
||||
|
||||
|
||||
;; TYPE: message x upd/tcp x dnsd-options -> message
|
||||
(define (dnsd-ask-resolver-rec msg proto dnsd-options)
|
||||
(set-message-source! msg (mc-message->octets msg))
|
||||
(let ((ch-timeout (make-channel))
|
||||
(ch-res (make-channel)))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(sleep (* 1000 (dnsd-options-rec-timeout dnsd-options)))
|
||||
(sync (send-rv ch-timeout #t))))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level debug)
|
||||
"Error during recursive lookup.")
|
||||
(msg-set-rcode! msg 2)
|
||||
msg)
|
||||
(lambda ()
|
||||
(sync (send-rv ch-res (dnsd-get-information msg
|
||||
proto dnsd-options)))))))
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-timeout)
|
||||
(lambda (ignore)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Timeout during recursive lookup. Current value is ~Ds"
|
||||
(dnsd-options-rec-timeout dnsd-options))
|
||||
(msg-set-rcode! msg 2) msg))
|
||||
(wrap (receive-rv ch-res)
|
||||
(lambda (value)
|
||||
value))))))
|
||||
|
||||
|
||||
;; TYPE: message x list-of-address32 x upd/tcp x dnsd-options -> message
|
||||
(define (dnsd-ask-resolver-direct msg nameservers proto dnsd-options)
|
||||
(set-message-source! msg (mc-message->octets msg))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level debug)
|
||||
"Error during direct lookup.")
|
||||
(msg-set-rcode! msg 2)
|
||||
msg)
|
||||
(lambda ()
|
||||
(dnsd-lookup-direct msg nameservers proto dnsd-options))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,177 @@
|
|||
; ----------------------------------
|
||||
; --- Resource-Record-Definition ---
|
||||
; ----------------------------------
|
||||
|
||||
; Wrapper for (make-resource-record ___) from dns.scm:
|
||||
; * Abstraction of (make-resource-record ___ (make-resource-record-data-* ___))
|
||||
; * Now for all supported types: (dns-rr-<type> ...)
|
||||
|
||||
|
||||
; 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.
|
||||
|
||||
|
||||
; Interface:
|
||||
|
||||
; (dns-rr-a ...)
|
||||
; (dns-rr-txt ...)
|
||||
; etc..
|
||||
|
||||
|
||||
|
||||
; Abstraction of (make-resource-record ... (make-resource-record-data-* ...))
|
||||
; Now: (dns-rr-* ...), trying to include data-integrity.
|
||||
|
||||
; *** Some stuff ***
|
||||
|
||||
(define (make-message-class class)
|
||||
(cond
|
||||
((number? class)
|
||||
(message-class-number->type class))
|
||||
((symbol? class)
|
||||
(message-class-symbol->type class))
|
||||
((message-class? class)
|
||||
class)
|
||||
(else #f)))
|
||||
|
||||
(define (make-message-type type)
|
||||
(cond
|
||||
((number? type)
|
||||
(message-type-number->type type))
|
||||
((symbol? type)
|
||||
(message-type-symbol->type type))
|
||||
((message-type? type)
|
||||
type)
|
||||
(else #f)))
|
||||
|
||||
(define (make-address32 ip)
|
||||
(cond
|
||||
((address32? ip) ip)
|
||||
((ip-string? ip)
|
||||
(ip-string->address32 ip))
|
||||
(else #f)))
|
||||
|
||||
|
||||
; Nice to know: valid ttls: 0-2147483647
|
||||
|
||||
; *02* - (dns-rr-* ...) functions:
|
||||
|
||||
; Warning: This functions won't work with any other class than 'IN'!
|
||||
|
||||
; TYPES: name x class x ttl x data -> resource-record-record-type or #f
|
||||
|
||||
(define (dns-rr-a name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(a32 (make-address32 data)))
|
||||
(make-resource-record
|
||||
name (message-type a)
|
||||
class ttl
|
||||
(make-resource-record-data-a a32))))
|
||||
|
||||
(define (dns-rr-ns name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(ns-name (make-fqdn-name data))
|
||||
(whatever (fqdn? ns-name)))
|
||||
(make-resource-record
|
||||
name (message-type ns)
|
||||
class ttl
|
||||
(make-resource-record-data-ns ns-name))))
|
||||
|
||||
(define (dns-rr-cname name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(cname-name (make-fqdn-name data))
|
||||
(whatever (fqdn? cname-name)))
|
||||
(make-resource-record
|
||||
name (message-type cname)
|
||||
class ttl
|
||||
(make-resource-record-data-cname cname-name))))
|
||||
|
||||
(define (dns-rr-soa name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(mname (make-fqdn-name (car data)))
|
||||
(whatever (fqdn? mname))
|
||||
(rname (make-fqdn-name (cadr data)))) ;! what's with fqdn...
|
||||
(make-resource-record
|
||||
name (message-type soa)
|
||||
class ttl
|
||||
(make-resource-record-data-soa
|
||||
mname rname
|
||||
(caddr data)
|
||||
(cadddr data)
|
||||
(cadr (cdddr data))
|
||||
(caddr (cdddr data))
|
||||
(cadddr (cdddr data))))))
|
||||
|
||||
(define (dns-rr-ptr name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(ptr-name (make-fqdn-name data))
|
||||
(whatever (fqdn? ptr-name)))
|
||||
(make-resource-record
|
||||
name (message-type ptr)
|
||||
class ttl
|
||||
(make-resource-record-data-ptr ptr-name))))
|
||||
|
||||
(define (dns-rr-hinfo name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in))))
|
||||
(make-resource-record
|
||||
name (message-type hinfo)
|
||||
class ttl
|
||||
(make-resource-record-data-hinfo data))))
|
||||
|
||||
(define (dns-rr-mx name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(pref (car data))
|
||||
(whatever (number? pref))
|
||||
(mx-name (make-fqdn-name (cadr data)))
|
||||
(whatever (fqdn? mx-name)))
|
||||
(make-resource-record
|
||||
name (message-type mx)
|
||||
class ttl
|
||||
(make-resource-record-data-mx
|
||||
pref mx-name))))
|
||||
|
||||
(define (dns-rr-txt name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in))))
|
||||
(make-resource-record
|
||||
name (message-type txt)
|
||||
class ttl
|
||||
(make-resource-record-data-txt data))))
|
||||
|
||||
(define (dns-rr-aaaa name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in))))
|
||||
(make-resource-record
|
||||
name (message-type aaaa)
|
||||
class ttl
|
||||
(make-resource-record-data-aaaa data))))
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
; -----------------------
|
||||
; --- Read/Write-Lock ---
|
||||
; -----------------------
|
||||
|
||||
; Locks for a DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; 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.
|
||||
|
||||
|
||||
; Simple locks for the dns-server database. The idea behind this sort of
|
||||
; lock is to permit multiple threads to read the data secured by the lock.
|
||||
; If a thread tries to write, it'll block all other access to the data
|
||||
; and do it's work isolated. (One write to block them all... ;-)
|
||||
|
||||
; Interface:
|
||||
|
||||
; (make-r/w-lock) : creates an r/w-lock
|
||||
|
||||
; (obtain-R/w-lock r/w-lock)
|
||||
; (obtain-r/W-lock r/w-lock)
|
||||
|
||||
; (release-R/w-lock r/w-lock)
|
||||
; (release-r/W-lock r/w-lock)
|
||||
|
||||
; (with-R/w-lock rwlock thunk)
|
||||
; (with-r/W-lock rwlock thunk)
|
||||
|
||||
|
||||
(define-record-type r/w-lock :r/w-lock
|
||||
(really-make-r/w-lock write-flag read-count write-lock mutex-lock)
|
||||
r/w-lock?
|
||||
(write-flag get-r/w-lock-write-flag set-r/w-lock-write-flag!)
|
||||
(read-count get-r/w-lock-read-count set-r/w-lock-read-count!)
|
||||
(write-lock get-r/w-lock-write-lock)
|
||||
(mutex-lock get-r/w-lock-mutex-lock))
|
||||
|
||||
(define (make-r/w-lock)
|
||||
(really-make-r/w-lock #f 0 (make-lock) (make-lock)))
|
||||
|
||||
(define (obtain-R/w-lock r/w-lock)
|
||||
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock)))
|
||||
(let loop ()
|
||||
(obtain-lock mutex-lock)
|
||||
; Is there is a thread writing?
|
||||
(if (get-r/w-lock-write-flag r/w-lock)
|
||||
(begin
|
||||
(release-lock mutex-lock)
|
||||
; Just wait for some time and try again...
|
||||
; TODO?: Do that with locks
|
||||
(relinquish-timeslice)
|
||||
(loop))
|
||||
(begin
|
||||
(set-r/w-lock-read-count!
|
||||
r/w-lock
|
||||
(+ 1 (get-r/w-lock-read-count r/w-lock)))
|
||||
(release-lock mutex-lock))))))
|
||||
|
||||
(define (release-R/w-lock r/w-lock)
|
||||
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock)))
|
||||
(obtain-lock mutex-lock)
|
||||
(set-r/w-lock-read-count!
|
||||
r/w-lock (- (get-r/w-lock-read-count r/w-lock) 1))
|
||||
(release-lock mutex-lock)))
|
||||
|
||||
(define (obtain-r/W-lock r/w-lock)
|
||||
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock))
|
||||
(write-lock (get-r/w-lock-write-lock r/w-lock)))
|
||||
; Maybe wait here for another write-thread:
|
||||
(obtain-lock write-lock)
|
||||
(let loop ()
|
||||
(obtain-lock mutex-lock)
|
||||
(set-r/w-lock-write-flag! r/w-lock #t)
|
||||
(if (= 0 (get-r/w-lock-read-count r/w-lock))
|
||||
(release-lock mutex-lock)
|
||||
(begin
|
||||
(release-lock mutex-lock)
|
||||
; Wait until the reads finish...
|
||||
; TODO?: Do that with locks
|
||||
(relinquish-timeslice)
|
||||
(loop))))))
|
||||
|
||||
(define (release-r/W-lock r/w-lock)
|
||||
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock))
|
||||
(write-lock (get-r/w-lock-write-lock r/w-lock)))
|
||||
(obtain-lock mutex-lock)
|
||||
(set-r/w-lock-write-flag! r/w-lock #f)
|
||||
(release-lock mutex-lock)
|
||||
(release-lock write-lock)))
|
||||
|
||||
(define (with-R/w-lock rwlock thunk)
|
||||
(obtain-R/w-lock rwlock)
|
||||
(let ((value (thunk)))
|
||||
(release-R/w-lock rwlock)
|
||||
value))
|
||||
|
||||
(define (with-r/W-lock rwlock thunk)
|
||||
(obtain-r/W-lock rwlock)
|
||||
(let ((value (thunk)))
|
||||
(release-r/W-lock rwlock)
|
||||
value))
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
; ----------------------
|
||||
; --- Semaphore-Lock ---
|
||||
; ----------------------
|
||||
|
||||
; Semaphore-locks for a DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; 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.
|
||||
|
||||
; Wait on the semaphore-lock if the semaphore-counter reaches 0
|
||||
|
||||
; Interface:
|
||||
|
||||
; (make-semaphore initial-value)
|
||||
|
||||
; (set-semaphore! new-value)
|
||||
|
||||
; (semaphore-post semaphore)
|
||||
|
||||
; (semaphore-wait semaphore)
|
||||
|
||||
|
||||
(define-record-type semaphore :semaphore
|
||||
(really-make-semaphore value i waiting-list mutex-lock)
|
||||
semaphore?
|
||||
(value get-semaphore-value set-semaphore-value!)
|
||||
(i get-semaphore-counter set-semaphore-counter!)
|
||||
(waiting-list get-semaphore-waiting set-semaphore-waiting!)
|
||||
(mutex-lock get-semaphore-lock))
|
||||
|
||||
(define (make-semaphore i)
|
||||
(really-make-semaphore i i '() (make-lock)))
|
||||
|
||||
;; Reset the internal semaphore-counter.
|
||||
(define (set-semaphore! sem new-value)
|
||||
(if (semaphore? sem)
|
||||
(begin
|
||||
(obtain-lock (get-semaphore-lock sem))
|
||||
(let* ((old-value (get-semaphore-value sem))
|
||||
(diff (- new-value old-value)))
|
||||
(set-semaphore-value! sem new-value)
|
||||
(set-semaphore-counter! sem (+ (get-semaphore-counter sem) diff))
|
||||
(release-lock (get-semaphore-lock sem))))
|
||||
(error "Not a semaphore.")))
|
||||
|
||||
|
||||
;; Release a lock, if one is held or add 1 to the counter.
|
||||
(define (semaphore-post sem)
|
||||
(if (semaphore? sem)
|
||||
(begin
|
||||
(obtain-lock (get-semaphore-lock sem))
|
||||
(let ((waiting-list (get-semaphore-waiting sem)))
|
||||
(if (null? waiting-list)
|
||||
(begin
|
||||
(set-semaphore-counter! sem (+ 1 (get-semaphore-counter sem)))
|
||||
(release-lock (get-semaphore-lock sem)))
|
||||
(let ((locked-thread (car waiting-list)))
|
||||
(set-semaphore-waiting! sem (cdr waiting-list))
|
||||
(release-lock locked-thread)
|
||||
(release-lock (get-semaphore-lock sem))))))
|
||||
(error "Not a semaphore.")))
|
||||
|
||||
|
||||
;; Wait on the semaphore if the counter is 0
|
||||
(define (semaphore-wait sem)
|
||||
(if (semaphore? sem)
|
||||
(begin
|
||||
(obtain-lock (get-semaphore-lock sem))
|
||||
(if (> (get-semaphore-counter sem) 0)
|
||||
(begin
|
||||
(set-semaphore-counter! sem (- (get-semaphore-counter sem) 1))
|
||||
(release-lock (get-semaphore-lock sem)))
|
||||
(let ((lock (make-lock)))
|
||||
(set-semaphore-waiting! sem
|
||||
(cons lock (get-semaphore-waiting sem)))
|
||||
(obtain-lock lock)
|
||||
(release-lock (get-semaphore-lock sem))
|
||||
(obtain-lock lock))))
|
||||
(error "Not a semaphore.")))
|
||||
|
|
@ -0,0 +1,364 @@
|
|||
; -----------------------
|
||||
; --- 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)))))
|
||||
Loading…
Reference in New Issue