diff --git a/scheme/dnsd/README b/scheme/dnsd/README new file mode 100644 index 0000000..cbb187e --- /dev/null +++ b/scheme/dnsd/README @@ -0,0 +1,82 @@ +*********************** +*** README for DNSD *** +*********************** + +Copyright (c) 2005/2006 by Norbert Freudemann + + 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 . + + + 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 or else use + + dnsd> (dnsd-start ) + + +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. \ No newline at end of file diff --git a/scheme/dnsd/db-options.scm b/scheme/dnsd/db-options.scm new file mode 100644 index 0000000..71276f5 --- /dev/null +++ b/scheme/dnsd/db-options.scm @@ -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 +; +; 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.")))) diff --git a/scheme/dnsd/etc/dnsd-options.scm b/scheme/dnsd/etc/dnsd-options.scm new file mode 100644 index 0000000..b3eb39a --- /dev/null +++ b/scheme/dnsd/etc/dnsd-options.scm @@ -0,0 +1,103 @@ +;; Option-File for DNSD: +;; --------------------- + +;; Options can be reloaded using the POSIX-Signal USR1. + + +;; External option representation : +;; --------------------------------------- + +;; (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 ) + +;; (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) + diff --git a/scheme/dnsd/etc/dnsd-post.scm b/scheme/dnsd/etc/dnsd-post.scm new file mode 100644 index 0000000..5177971 --- /dev/null +++ b/scheme/dnsd/etc/dnsd-post.scm @@ -0,0 +1,3 @@ +(lambda (msg socket-addr dnsd-options) + (display "Postprocessing works.") + (values msg dnsd-options)) \ No newline at end of file diff --git a/scheme/dnsd/etc/dnsd-pre.scm b/scheme/dnsd/etc/dnsd-pre.scm new file mode 100644 index 0000000..dd48e5c --- /dev/null +++ b/scheme/dnsd/etc/dnsd-pre.scm @@ -0,0 +1,3 @@ +(lambda (msg socket-addr dnsd-options) + (display "Preprocessing works.") + (values msg dnsd-options)) diff --git a/scheme/dnsd/etc/dnsd-zones.scm b/scheme/dnsd/etc/dnsd-zones.scm new file mode 100644 index 0000000..71c6a05 --- /dev/null +++ b/scheme/dnsd/etc/dnsd-zones.scm @@ -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 : +;; -------------------------------------- + +;; 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: + +() \ No newline at end of file diff --git a/scheme/dnsd/etc/zone-example-rfc b/scheme/dnsd/etc/zone-example-rfc new file mode 100644 index 0000000..97363b3 --- /dev/null +++ b/scheme/dnsd/etc/zone-example-rfc @@ -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 diff --git a/scheme/dnsd/etc/zone-example-scheme b/scheme/dnsd/etc/zone-example-scheme new file mode 100644 index 0000000..ad8d2cf --- /dev/null +++ b/scheme/dnsd/etc/zone-example-scheme @@ -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"))) \ No newline at end of file diff --git a/scheme/dnsd/logging.scm b/scheme/dnsd/logging.scm new file mode 100644 index 0000000..b0945c5 --- /dev/null +++ b/scheme/dnsd/logging.scm @@ -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 +; + +; 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))) \ No newline at end of file diff --git a/scheme/dnsd/masterfile-parser.scm b/scheme/dnsd/masterfile-parser.scm new file mode 100644 index 0000000..b02bd2f --- /dev/null +++ b/scheme/dnsd/masterfile-parser.scm @@ -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 +; +; 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: {|@|} [] [] +;; 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: +;; ::= $ORIGIN +;; | $INCLUDE ... +;; | $TTL (defined in RFC 2308) +;; | +;; 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 + ((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.")) + ; + (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))) diff --git a/scheme/dnsd/masterfile.l b/scheme/dnsd/masterfile.l new file mode 100644 index 0000000..261c65e --- /dev/null +++ b/scheme/dnsd/masterfile.l @@ -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 +; +; 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 +<> (error (yygetc)) diff --git a/scheme/dnsd/masterfile.l.scm b/scheme/dnsd/masterfile.l.scm new file mode 100644 index 0000000..30d7b4e --- /dev/null +++ b/scheme/dnsd/masterfile.l.scm @@ -0,0 +1,1286 @@ +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; This program is free software; you can redistribute it and/or +; modify it under the terms of the GNU General Public License +; as published by the Free Software Foundation; either version 2 +; of the License, or (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. +; +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<>-action #f) + (<>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <>-action et de <>-action + (set! <>-action (prepare-special-action <>-pre-action)) + (set! <>-action (prepare-special-action <>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<>-action (vector-ref tables 1)) + (<>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <>-action + <>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <>-pre-action <>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file masterfile.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (error (yygetc)) + )) + (vector + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + (yycontinue) + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'newline + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'blank-newline + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + (let loop ((c (yygetc))) + (cond + ((eq? 'eof c) 'eof) + ((char=? #\newline c) + (begin + (yyungetc) + (yycontinue))) + (else (loop (yygetc))))) + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'left-par + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'right-par + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'origin + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'include + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'generate + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'ttl + )) + #f + (lambda (yycontinue yygetc yyungetc) + (lambda (yyline) + 'origin-ref + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + yytext + ))) + 'decision-trees + 0 + 0 + '#((1037 (1011 (1009 1 (1010 8 7)) (1033 (1032 1 8) (1036 1 3))) (1059 + (1041 (1040 1 5) (1042 4 1)) (1064 (1060 6 1) (1065 2 1)))) (1040 (1011 + (1009 1 err) (= 1032 err 1)) (1060 (1042 err (1059 1 err)) (= 1064 err + 1))) err (1064 (1033 (1011 (1009 1 err) (1032 1 err)) (1042 (1040 1 + err) (= 1059 err 1))) (1074 (1071 (1065 err 1) (1072 10 (1073 1 11))) + (1080 (1079 1 12) (= 1084 9 1)))) err err err (1010 (1009 err 13) (= + 1032 13 err)) err (1042 (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 + err))) (1064 (= 1059 err 1) (1084 (1065 err 1) (1085 14 1)))) (1042 + (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err + 1) (1069 (1065 err 1) (1070 15 1)))) (1042 (1032 (1009 1 (1011 err 1)) + (1033 err (1040 1 err))) (1064 (= 1059 err 1) (1078 (1065 err 1) (1079 + 16 1)))) (1042 (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 err))) + (1064 (= 1059 err 1) (1082 (1065 err 1) (1083 17 1)))) err (1042 (1032 + (1009 1 (1011 err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err 1) + (1076 (1065 err 1) (1077 18 1)))) (1042 (1032 (1009 1 (1011 err 1)) + (1033 err (1040 1 err))) (1064 (= 1059 err 1) (1078 (1065 err 1) (1079 + 19 1)))) (1042 (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 err))) + (1064 (= 1059 err 1) (1067 (1065 err 1) (1068 20 1)))) (1042 (1032 + (1009 1 (1011 err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err 1) + (1073 (1065 err 1) (1074 21 1)))) (1040 (1011 (1009 1 err) (= 1032 err + 1)) (1060 (1042 err (1059 1 err)) (= 1064 err 1))) (1042 (1032 (1009 1 + (1011 err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err 1) (1069 (1065 + err 1) (1070 22 1)))) (1042 (1032 (1009 1 (1011 err 1)) (1033 err (1040 + 1 err))) (1064 (= 1059 err 1) (1076 (1065 err 1) (1077 23 1)))) (1042 + (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err + 1) (1071 (1065 err 1) (1072 24 1)))) (1042 (1032 (1009 1 (1011 err 1)) + (1033 err (1040 1 err))) (1064 (= 1059 err 1) (1082 (1065 err 1) (1083 + 25 1)))) (1042 (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 err))) + (1064 (= 1059 err 1) (1085 (1065 err 1) (1086 26 1)))) (1042 (1032 + (1009 1 (1011 err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err 1) + (1073 (1065 err 1) (1074 27 1)))) (1042 (1032 (1009 1 (1011 err 1)) + (1033 err (1040 1 err))) (1064 (= 1059 err 1) (1065 err (1066 28 1)))) + (1042 (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 err))) (1064 (= + 1059 err 1) (1068 (1065 err 1) (1069 29 1)))) (1042 (1032 (1009 1 (1011 + err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err 1) (1078 (1065 err + 1) (1079 30 1)))) (1042 (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 + err))) (1064 (= 1059 err 1) (1084 (1065 err 1) (1085 31 1)))) (1042 + (1032 (1009 1 (1011 err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err + 1) (1069 (1065 err 1) (1070 32 1)))) (1040 (1011 (1009 1 err) (= 1032 + err 1)) (1060 (1042 err (1059 1 err)) (= 1064 err 1))) (1042 (1032 + (1009 1 (1011 err 1)) (1033 err (1040 1 err))) (1064 (= 1059 err 1) + (1069 (1065 err 1) (1070 33 1)))) (1040 (1011 (1009 1 err) (= 1032 err + 1)) (1060 (1042 err (1059 1 err)) (= 1064 err 1))) (1040 (1011 (1009 1 + err) (= 1032 err 1)) (1060 (1042 err (1059 1 err)) (= 1064 err 1)))) + '#((11 . 11) (11 . 11) (10 . 10) (11 . 11) (5 . 5) (4 . 4) (3 . 3) (1 . + 1) (0 . 0) (11 . 11) (11 . 11) (11 . 11) (11 . 11) (2 . 2) (11 . 11) + (11 . 11) (11 . 11) (11 . 11) (9 . 9) (11 . 11) (11 . 11) (11 . 11) (11 + . 11) (11 . 11) (11 . 11) (11 . 11) (11 . 11) (11 . 11) (11 . 11) (11 . + 11) (6 . 6) (11 . 11) (7 . 7) (8 . 8)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/scheme/dnsd/options.scm b/scheme/dnsd/options.scm new file mode 100644 index 0000000..998ec47 --- /dev/null +++ b/scheme/dnsd/options.scm @@ -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 +; +; 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."))) + + diff --git a/scheme/dnsd/resolver.scm b/scheme/dnsd/resolver.scm new file mode 100644 index 0000000..bbb7f06 --- /dev/null +++ b/scheme/dnsd/resolver.scm @@ -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 +; + +; 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)))) + + + diff --git a/scheme/dnsd/rr-def.scm b/scheme/dnsd/rr-def.scm new file mode 100644 index 0000000..d0aa1cc --- /dev/null +++ b/scheme/dnsd/rr-def.scm @@ -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- ...) + + +; This file is part of the Scheme Untergrund Networking package + +; Copyright (c) 2005/2006 by Norbert Freudemann +; + +; 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)))) diff --git a/scheme/dnsd/rw-locks.scm b/scheme/dnsd/rw-locks.scm new file mode 100644 index 0000000..dbc5434 --- /dev/null +++ b/scheme/dnsd/rw-locks.scm @@ -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 +; +; 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)) \ No newline at end of file diff --git a/scheme/dnsd/semaphores.scm b/scheme/dnsd/semaphores.scm new file mode 100644 index 0000000..94ad3dd --- /dev/null +++ b/scheme/dnsd/semaphores.scm @@ -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 +; +; 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."))) diff --git a/scheme/dnsd/slist.scm b/scheme/dnsd/slist.scm new file mode 100644 index 0000000..111acc4 --- /dev/null +++ b/scheme/dnsd/slist.scm @@ -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 +; + +; 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)))))