sunet/scheme/dnsd/masterfile-parser.scm

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