370 lines
12 KiB
Scheme
370 lines
12 KiB
Scheme
; -------------------------
|
|
; --- Masterfile-Parser ---
|
|
; -------------------------
|
|
|
|
; Parser for Masterfiles based on the RFCs: 1034 / 1035 / 2308 and
|
|
; the BIND-Time-Value-Format convention.
|
|
|
|
; This file is part of the Scheme Untergrund Networking package
|
|
|
|
; Copyright (c) 2005/2006 by Norbert Freudemann
|
|
; <nofreude@informatik.uni-tuebingen.de>
|
|
; For copyright information, see the file COPYING which comes with
|
|
; the distribution.
|
|
|
|
|
|
; Interface:
|
|
; ----------
|
|
|
|
; (parse-mf fileaname dnsd-options) -> list-of-resource-records
|
|
|
|
|
|
;; Lexer:
|
|
;; ------
|
|
|
|
;; The lexer was generated using SILex v1.0 by Danny Dubé with
|
|
;; specification file "masterfile.l"
|
|
;; For more information about SILex visit: http://www.iro.umontreal.ca/~dube/
|
|
;; TYPE: filename x dnsd-options -> list-of-lexems or #f
|
|
(define (lex-masterfile file dnsd-options)
|
|
(with-fatal-error-handler*
|
|
(lambda (condition decline)
|
|
(dnsd-log (syslog-level info)
|
|
"Error while parsing the file ~S"
|
|
file)
|
|
(dnsd-log (syslog-level debug)
|
|
"Above condition is: ~A"
|
|
condition)
|
|
#f)
|
|
(lambda ()
|
|
(and-let* ((the-path (string-append (dnsd-options-dir dnsd-options) file))
|
|
(whatever (file-name-non-directory? the-path))
|
|
(the-port (open-input-file the-path)))
|
|
(lexer-init 'port the-port)
|
|
(let loop ((l '()))
|
|
(let ((lexem (lexer)))
|
|
(if (eq? lexem 'eof)
|
|
(begin
|
|
(close-input-port the-port)
|
|
(reverse (cons lexem l)))
|
|
(loop (cons lexem l)))))))))
|
|
|
|
|
|
;; Parser:
|
|
;; -------
|
|
|
|
;; Maybe append a domain-origin to a string:
|
|
;; TYPE: dn-label-string x fqdn-string -> fqdn-string
|
|
(define (parse-mf-maybe-append-origin name origin)
|
|
(let ((l (string-length name)))
|
|
(if (and (not (= 0 l)) (not (char=? #\. (string-ref name (- l 1)))))
|
|
(if (string=? origin ".")
|
|
(string-append name origin)
|
|
(string-append name "." origin))
|
|
name)))
|
|
|
|
|
|
;; Parse (or restore) the name of the current line:
|
|
;; TYPE: dn-label-string or symbol x fqdn-string x dn-label-string ->
|
|
;; fqdn x dn-label-string
|
|
(define (parse-mf-node-name? elem origin last-name)
|
|
(cond
|
|
((eq? elem 'origin-ref) (values origin origin)) ; @ in the masterfile
|
|
((eq? elem 'blank) ; no name given - use last one
|
|
(values (parse-mf-maybe-append-origin last-name origin) last-name))
|
|
(else (values (parse-mf-maybe-append-origin elem origin) elem))))
|
|
|
|
|
|
;; Parse the type of a rr-line:
|
|
;; TYPE: string -> message-type
|
|
(define (parse-mf-type? elem)
|
|
(message-type-symbol->type (string->symbol (string-downcase elem))))
|
|
|
|
|
|
;; Parse the class of a rr-line:
|
|
;; TYPE: string -> message-class
|
|
(define (parse-mf-class? elem)
|
|
(message-class-symbol->type (string->symbol (string-downcase elem))))
|
|
|
|
|
|
;; Parse a RFC-time value or a BIND-Masterfiles value: #w#d#h#m#s
|
|
;; eg. 1 Week = 1w or 1d20s = 1 day and 20 seconds
|
|
;; This algorithm is very liberal - a possible value would be 12s1d1w1s
|
|
;; TYPE: string -> number
|
|
(define (parse-mf-time-value? elem)
|
|
(let loop ((str elem)
|
|
(counter 0)
|
|
(val 0))
|
|
(let ((l (string-length str)))
|
|
(if (= l 0)
|
|
val
|
|
(let ((sub (substring str counter (+ counter 1))))
|
|
(if (string->number sub)
|
|
(if (= counter (- l 1))
|
|
(string->number str) ; original RFC format
|
|
(loop str (+ counter 1) val))
|
|
(let ((val2 (string->number (substring str 0 counter)))
|
|
(rest-string (substring str (+ counter 1) l)))
|
|
(cond
|
|
((string-ci=? sub "w")
|
|
(loop rest-string 0 (+ val (* 7 24 60 60 val2))))
|
|
((string-ci=? sub "d")
|
|
(loop rest-string 0 (+ val (* 24 60 60 val2))))
|
|
((string-ci=? sub "h")
|
|
(loop rest-string 0 (+ val (* 60 60 val2))))
|
|
((string-ci=? sub "m")
|
|
(loop rest-string 0 (+ val (* 60 val2))))
|
|
((string-ci=? sub "s")
|
|
(loop rest-string 0 (+ val val2)))
|
|
(else
|
|
(display elem)
|
|
(error "Wrong time-value format"))))))))))
|
|
|
|
|
|
;; Parse a rr-line:
|
|
;; Syntax: {<domain>|@|<blank>} [<ttl>] [<class>] <type> <rdata>
|
|
;; The algorithm has to guess serveral times which value actually
|
|
;; is been parsed.
|
|
;; TYPE: rr-line-of-lexems x fqdn x dn-string x ttl-number
|
|
;; -> '(name ttl class type rdata origin) x fqdn x dn-string x ttl-number
|
|
(define (parse-mf-rr line origin current-rr-name the-ttl)
|
|
(receive
|
|
(rr-name current-rr-name)
|
|
(parse-mf-node-name? (car line) origin current-rr-name)
|
|
(let* ((sec (cadr line))
|
|
(type (parse-mf-type? sec)))
|
|
(if type ; Parsing the type?
|
|
(values (list rr-name the-ttl #f type (cddr line) origin)
|
|
origin current-rr-name the-ttl)
|
|
(let ((class (parse-mf-class? sec)))
|
|
(if class ; Parsing a class?
|
|
(let ((type (parse-mf-type? (caddr line))))
|
|
(values (list rr-name the-ttl class type (cdddr line) origin)
|
|
origin current-rr-name the-ttl))
|
|
(let ((ttl (parse-mf-time-value? sec)))
|
|
(if ttl ; Now it should be a TTL.
|
|
(let* ((third (caddr line))
|
|
(type (parse-mf-type? third)))
|
|
(if type
|
|
(values
|
|
(list rr-name ttl #f type (cdddr line) origin)
|
|
origin current-rr-name the-ttl)
|
|
(let ((type (parse-mf-type? (cadddr line))))
|
|
(values
|
|
(list
|
|
rr-name ttl (parse-mf-class? third) type
|
|
(cdr (cdddr line)) origin)
|
|
origin current-rr-name the-ttl))))
|
|
(begin
|
|
(display line)
|
|
(error "Parsed a bad line!"))))))))))
|
|
|
|
|
|
|
|
;; Parse a masterfile-line:
|
|
;;<line> ::= $ORIGIN <domain-name>
|
|
;; | $INCLUDE ...
|
|
;; | $TTL <number> (defined in RFC 2308)
|
|
;; | <resource-record>
|
|
;; TODO: | $GENERATE ... BIND-Version 9
|
|
;;
|
|
;; TYPE: mf-line x fqdn x dn-string x ttl-number x dnsd-options
|
|
;; -> symbol or list-of-a-rr x fqdn x dn-string x ttl-number
|
|
(define (parse-mf-line line origin current-rr-name ttl dnsd-options)
|
|
(let ((first (car line)))
|
|
(cond
|
|
;; $INCLUDE
|
|
((eq? first 'include)
|
|
(let* ((file-name (cadr line))
|
|
(maybe-origin (if (= (length line) 3) (caddr line) #f))
|
|
(lexed-file (lex-masterfile file-name dnsd-options))
|
|
(line-list (parse-mf-lex->lines lexed-file))
|
|
(res (parse-mf-lexem-list
|
|
line-list (if maybe-origin maybe-origin origin)
|
|
current-rr-name #f dnsd-options)))
|
|
(values res origin current-rr-name ttl)))
|
|
;; $ORIGIN
|
|
((eq? first 'origin)
|
|
(let ((new-origin (cadr line)))
|
|
(values 'ORIGIN
|
|
(parse-mf-maybe-append-origin new-origin origin)
|
|
current-rr-name ttl)))
|
|
;; $TTL <number>
|
|
((eq? first 'ttl)
|
|
(let ((new-ttl (cadr line)))
|
|
(values 'TTL origin current-rr-name (parse-mf-time-value? new-ttl))))
|
|
;; $GENERATE ...
|
|
((eq? first 'generate)
|
|
(error "parse-masterfile: GENERATE is not supported."))
|
|
; <resource-record>
|
|
(else (parse-mf-rr line origin current-rr-name ttl)))))
|
|
|
|
|
|
;; Transforms the lexer-output into a list of lines:
|
|
;; TYPE: list-of-lexems -> list-of-lexem-lists
|
|
(define (parse-mf-lex->lines lex-list)
|
|
(let loop ((l lex-list)
|
|
(line '())
|
|
(ignore-line #f) ; Toggle comments.
|
|
(res '()))
|
|
(let ((first (car l)))
|
|
(cond
|
|
((eq? first 'eof)
|
|
(if (null? line)
|
|
(reverse res)
|
|
(reverse (cons line res))))
|
|
((eq? first 'left-par) ; Ignore line-breaks.
|
|
(loop (cdr l) line #t res))
|
|
((eq? first 'right-par) ; Consider line-breaks.
|
|
(loop (cdr l) line #f res))
|
|
((eq? first 'newline)
|
|
(if (not ignore-line)
|
|
(if (null? line)
|
|
(loop (cdr l) '() ignore-line res)
|
|
(loop (cdr l) '() ignore-line (cons line res)))
|
|
(loop (cdr l) line ignore-line res)))
|
|
((eq? first 'blank-newline)
|
|
(if (not ignore-line)
|
|
(if (null? line)
|
|
(loop (cdr l) (list 'blank) ignore-line res)
|
|
(loop (cdr l) (list 'blank) ignore-line (cons line res)))
|
|
(loop (cdr l) line ignore-line res)))
|
|
(else
|
|
(loop (cdr l) (append line (list first)) ignore-line res))))))
|
|
|
|
|
|
;; Actually create a resourc-record from the parsed rr-line:
|
|
;; TYPE: '(name ttl class type rdata origin) -> resource-record-data
|
|
(define (parse-mf-create-rr line)
|
|
(let ((class (caddr line))
|
|
(type (cadddr line)))
|
|
(if (not (eq? (message-class in) class))
|
|
(begin
|
|
(display "Message-class not supported: ")
|
|
(display class)
|
|
(newline))
|
|
(let ((name (car line))
|
|
(ttl (cadr line))
|
|
(data (list-ref line 4))
|
|
(origin (list-ref line 5)))
|
|
(cond
|
|
((eq? type (message-type a))
|
|
(dns-rr-a name class ttl (car data)))
|
|
((eq? type (message-type ns))
|
|
(dns-rr-ns name class ttl
|
|
(parse-mf-maybe-append-origin (car data) origin)))
|
|
((eq? type (message-type cname))
|
|
(dns-rr-cname name class ttl
|
|
(parse-mf-maybe-append-origin (car data) origin)))
|
|
((eq? type (message-type soa))
|
|
(and-let* ((mname (parse-mf-maybe-append-origin (car data) origin))
|
|
(rname (parse-mf-maybe-append-origin (cadr data) origin))
|
|
(serial (string->number (caddr data)))
|
|
(refresh (parse-mf-time-value? (cadddr data)))
|
|
(retry (parse-mf-time-value? (list-ref data 4)))
|
|
(expire (parse-mf-time-value? (list-ref data 5)))
|
|
(minimum (parse-mf-time-value? (list-ref data 6))))
|
|
(dns-rr-soa name class ttl
|
|
(list mname rname serial
|
|
refresh retry expire minimum))))
|
|
((eq? type (message-type ptr))
|
|
(dns-rr-ptr name class ttl
|
|
(parse-mf-maybe-append-origin (car data) origin)))
|
|
((eq? type (message-type hinfo))
|
|
(dns-rr-hinfo name class ttl data))
|
|
((eq? type (message-type mx))
|
|
(let ((pref (string->number (car data)))
|
|
(exchange (parse-mf-maybe-append-origin (cadr data) origin)))
|
|
(dns-rr-mx name class ttl (list pref exchange))))
|
|
((eq? type (message-type txt))
|
|
(dns-rr-txt name class ttl data))
|
|
((eq? type (message-type aaaa))
|
|
(dns-rr-aaaa name class ttl (car data)))
|
|
(else #f))))))
|
|
|
|
|
|
;; Parse the list-of-lexems and return a list of resource-records:
|
|
;; TYPE: list-of-lexems x fqdn x dn-string x ttl-number x dnsd-options
|
|
;; -> list-of-resource-records
|
|
(define (parse-mf-lexem-list l origin current-rr-name ttl dnsd-options)
|
|
(let loop ((l l)
|
|
(res '())
|
|
(origin origin)
|
|
(current-rr-name current-rr-name)
|
|
(ttl ttl))
|
|
(if (null? l)
|
|
res
|
|
(receive (next-res origin current-rr-name ttl)
|
|
(parse-mf-line (car l) origin current-rr-name ttl
|
|
dnsd-options)
|
|
(cond
|
|
((or (eq? next-res 'ORIGIN)
|
|
(eq? next-res 'TTL))
|
|
(loop (cdr l) res origin current-rr-name ttl))
|
|
((and (list? next-res) ; result from INCLUDE...
|
|
(list? (car next-res)))
|
|
(loop (cdr l) (append next-res res) origin
|
|
current-rr-name ttl))
|
|
(else
|
|
(loop (cdr l) (cons next-res res) origin
|
|
current-rr-name ttl)))))))
|
|
|
|
|
|
;; Stuff for the main parser algorithm:
|
|
;; ------------------------------------
|
|
|
|
;; Searches the results of parse-mf-line for a message-class
|
|
(define (get-message-class rrlist)
|
|
(let loop ((res rrlist))
|
|
(if (null? res)
|
|
#f
|
|
(let ((class (caddr (car res))))
|
|
(if class class
|
|
(loop (cdr res)))))))
|
|
|
|
;; Set the results of parse-mf-line to a message-class...
|
|
(define (set-message-class rrlist class)
|
|
(map (lambda (e)
|
|
(cons (car e) (cons (cadr e) (cons class (cdddr e)))))
|
|
rrlist))
|
|
|
|
;; Searches the results of parse-mf-line for the shortest ttl
|
|
(define (get-soa-ttl rrlist)
|
|
(let loop ((l rrlist))
|
|
(if (null? l)
|
|
#f
|
|
(let* ((rrs (car l))
|
|
(rr-type (cadddr rrs)))
|
|
(if (eq? (message-type soa) rr-type)
|
|
(let* ((rdata (cadddr (cdr rrs))))
|
|
(parse-mf-time-value? (list-ref rdata 6)))
|
|
(loop (cdr l)))))))
|
|
|
|
;; Set the ttl of lines without one...
|
|
(define (set-ttl rrlist soa-ttl)
|
|
(map (lambda (e)
|
|
(let ((ttl (cadr e)))
|
|
(if (and ttl
|
|
(< soa-ttl ttl))
|
|
e
|
|
(cons (car e) (cons soa-ttl (cddr e))))))
|
|
rrlist))
|
|
|
|
|
|
;; The main parser algorithm:
|
|
;; --------------------------
|
|
|
|
;; Create a list of lexems and parse the lexems into resource-record-data:
|
|
;; TYPE: string x dnsd-options -> list-of-resourec-records
|
|
(define (parse-mf file dnsd-options)
|
|
(and-let* ((lex-list (lex-masterfile file dnsd-options))
|
|
(lines (parse-mf-lex->lines lex-list))
|
|
(res (parse-mf-lexem-list lines "." "" #f dnsd-options))
|
|
(class (get-message-class res))
|
|
(res (set-message-class res class))
|
|
(soa-ttl (get-soa-ttl res))
|
|
(res (set-ttl res soa-ttl))
|
|
(res (map (lambda (e) (parse-mf-create-rr e)) res)))
|
|
;; Check if there is a line with an error:
|
|
(fold-right (lambda (e l) (if (and e l) (cons e l) #f)) '() res)))
|