sunet/scheme/dnsd/database.scm

;; ---------------------
;; --- dnsd-database ---
;; ---------------------

; A simple database for dnsd.scm

; This file is part of the Scheme Untergrund Networking package

; Copyright (c) 2005/2006 by Norbert Freudemann 
;                            <nofreude@informatik.uni-tuebingen.de>

; For copyright information, see the file COPYING which comes with
; the distribution.

; Naming-Scheme:
; --------------

; dbi-    == No locks (should not be exported)
; db-     == With locks

; Lock-Safe Database-Interface:
; -----------------------------

; (db-clear-database)
; (db-clear-zone name class)
; (db-update-zone zone-list)
; (db-get-zone name class)
; (db-get-zone-for-axfr name class)
; (db-get-zone-soa-rr name class)
; (db-pretty-print)

; Query/Database-Interface
; ------------------------

; (db-lookup-rec qname class type)

; Database Structure:
; ------------------- 
; db-class-table: hash-table to db-zones
;  |
;  |-->db-zones-table: hash-table to db-zone
;       |  
;       |-->db-zone: hash-table to db-rr
;            |
;            |-->db-rr-table: hash-table to lists of resource-records
;                             of a given message-type


;; Some stuff:
;; -----------

;; Should be a dnsd-option?
(define *debug-info* #t)

 
;; Make a key for the database: 
;; TYPE: string -> string
(define (make-key-name name)
  (let ((last-char (string-ref name (- (string-length name) 1))))
    (string-downcase (if (not (char=? #\. last-char))
			 (string-append name ".")
			 name))))

;; Compare the first string with the rear of the second string.
;; TYPE: string x string -> boolean
(define (string-ci-zone-name=? zone name)
  (let ((l1 (string-length zone))
	(l2 (string-length name)))
    (if (<= l1 l2) (string-ci=? zone (substring name (- l2 l1) l2)) #f)))

;; Search a list of resource-records for the soa-rr:
;; TYPE: list-of-rrs -> soa-rr or #f
(define (maybe-get-soa-rr l)
  (let loop ((l l))
    (if (null? l)
	#f
	(let ((e (car l)))
	  (if (resource-record-data-soa? 
	       (resource-record-data e))
	      e
	      (loop (cdr l)))))))


;; Get the name of a zone from a soa-rr within a zone-list:
;; TYPE: list-of-rrs -> zone-name or #f
(define (maybe-get-soa-rr-name l)
  (and-let* ((soa-rr (maybe-get-soa-rr l)))
    (resource-record-name soa-rr)))


;; TYPE : list-or-rrs -> list-of-rrs
(define (get-zone-list-w/o-soa l)
  (fold-right
   (lambda (e l)
     (if (resource-record-data-soa? (resource-record-data e)) l (cons e l)))
   '() l))

;; TODO: Do this different...
(define display-debug
  (lambda args
    (if *debug-info*
	(begin
	  (display "dnsd: ")
	  (map (lambda (e) (display e) (display " ")) args)
	  (newline))
	#f)))

;; Duplicate a resource-record: (Needed for wildcard-replies)
(define (duplicate-rr name rr)
  (make-resource-record name 
			(resource-record-type rr)
			(resource-record-class rr)
			(resource-record-ttl rr)
			(resource-record-data rr)))


; ---------------------------
; --- Database definition ---
; ---------------------------

; Record-types:
; -------------

; db-rr-table stores the resource-records of ONE domain-name.
; hash-table  is a symbol-table with 'message-type' as keys
;             and a list of resource-record of the key-message-type as data.
; glue-data   stores the information (as boolean) if the given domain-name
;             is for glue-data or official.
(define-record-type db-rr-table :db-rr-table
  (really-make-db-rr-table hash-table glue-data)
  db-rr-table?
  (hash-table db-rr-table-hash-table)
  (glue-data db-rr-table-glue-data? set-db-rr-table-glue-data?!))

(define (make-db-rr-table) (really-make-db-rr-table (make-symbol-table) #f))


; db-zone        stores data (in form of db-rr-tables) for an entire zone 
;                as given by e.g. a masterfile
; hash-table     a string-table. Keys are the domain-names of the zone
;                to link to db-rr-tables.
; name           the name of the zone.
; soa-rr         for easy-access :-)
(define-record-type db-zone :db-zone
  (really-make-db-zone hash-table name soa-rr)
  db-zone?
  (hash-table db-zone-table)
  (name db-zone-name)
  (soa-rr get-db-zone-soa-rr))

(define (make-db-zone name soa-rr)
  (let ((primary-name (resource-record-data-soa-mname 
		       (resource-record-data soa-rr))))
    (really-make-db-zone (make-string-table) name soa-rr)))


; db-zones-table stores all zones of a given message-class
; hash-table     key is the zone-name. 
(define-record-type db-zones-table :db-zones-table
  (really-make-db-zones-table hash-table)
  db-zones-table?
  (hash-table db-zones-table-hash-table))

(define (make-db-zones-table) (really-make-db-zones-table (make-string-table)))


; db-class-table entry-point for the db.
; hash-table     key is the message-class (e.g. in) data are db-zones-tables
; r/w-lock       lock for exclusive-write-access.
(define-record-type db-class-table :db-class-table
  (really-make-db-class-table hash-table r/w-lock)
  db-class-table?
  (hash-table db-class-table-hash-table set-db-class-table-hash-table!)
  (r/w-lock db-class-table-r/w-lock))

(define *database* (really-make-db-class-table (make-symbol-table) 
					       (make-r/w-lock)))


; Predicates:
; -----------

; Check if there is data for a given message-class:
; TYPE: message-class -> boolean
(define (dbi-class? class)
  (if (table-ref (db-class-table-hash-table *database*) 
		 (message-class-name class)) 
      #t #f))


;; Modifiers:
;; ----------

;; Delete the whole data in the database:
(define (db-clear-database)
  (with-r/W-lock 
   (db-class-table-r/w-lock *database*)
   (lambda ()
     (set-db-class-table-hash-table! *database* (make-symbol-table)))))


;; Delete a zone (if present) with name 'name' from the database:
;; TYPE: string x message-class -> boolean
(define (db-clear-zone name class)
  (with-r/W-lock 
   (db-class-table-r/w-lock *database*)
   (lambda ()
     (and-let* ((whatever (dbi-class? class))
		(class-table (db-class-table-hash-table *database*))
		(zones-type (table-ref class-table (message-class-name class)))
		(zones-table (db-zones-table-hash-table zones-type))
		(key-name (make-key-name name))
		(whatever (table-ref zones-table key-name)))
       (table-set! zones-table key-name #f)))))


;; Stuff for db-add-zone:

;; Add a new class (if not already present) to the database:
;; TYPE: message-class -> unspecific
(define (dbi-maybe-add-class class)
  (if (not (dbi-class? class))
      (table-set! (db-class-table-hash-table *database*)
		  (message-class-name class)
		  (make-db-zones-table))))



;; --- Detection of Zone-Rules ---


;; Detect and mark glue data (domains with NS and all of their subdomains)
;; Give a warning, if the zone-tree is broken
;; TYPE: db-def-table x string -> unspecific
(define (dbi-mark-glue-in-zone def-table zone-name)
  (let ((tree (db-zone-table def-table)))
    (table-walk
     (lambda (key element)
       (if (table-ref (db-rr-table-hash-table element) 
		      (message-type-name (message-type a)))
	   (let loop ((name key))
	     (if (string-ci=? name zone-name)
		 #t
		 (let ((zone-entry (table-ref tree name)))
		   (if zone-entry
		       (if (table-ref (db-rr-table-hash-table zone-entry)
				      (message-type-name (message-type ns)))
			   (set-db-rr-table-glue-data?! element #t)
			   (loop (cut-name name)))
		       ;; Be tolerant if the domain tree is broken...
		       (begin
			 (dnsd-log (syslog-level info)
				   "Warning (re)loading zone ~S. Broken tree: Domain ~S is missing!"
				   zone-name name)
			 (loop (cut-name name)))))))
	   #t))
     tree)))


;; Ensures the min. TTL from the soa-rr of the zone. Has to be called
;; after dbi-mark-glue-in-zone!
;; TYPE: db-def-table x soa-rr -> unspecific
(define (dbi-ensure-min-ttl def-table soa-rr)
  (let ((min-ttl (resource-record-data-soa-minimum 
		  (resource-record-data soa-rr))))
    (table-walk
     (lambda (key element)
       (if (not (db-rr-table-glue-data? element))
	   (table-walk
	    (lambda (tkey telement)
	      (table-set! (db-rr-table-hash-table element)
			  tkey
			  (map (lambda (e)
				 (let ((rr-ttl (resource-record-ttl e)))
				   (make-resource-record 
				    (resource-record-name e)
				    (resource-record-type e)
				    (resource-record-class e)
				    (if (< rr-ttl min-ttl) 
					min-ttl rr-ttl)
				    (resource-record-data e))))
			       telement)))
	    (db-rr-table-hash-table element))))
     (db-zone-table def-table))))


;; Give a warning, if a Zone with a CNAME-RR contains other stuff...
;; TYPE: db-def-table -> unspecific
(define (dbi-cname-warning def-table zone-name)
  (table-walk
   (lambda (key element)
     (let ((rr-table (db-rr-table-hash-table element))
	   (cname (message-type-name (message-type cname))))
       (if (table-ref rr-table cname)
	   (table-walk
	    (lambda (k e)
	      (if (not (eq? k cname))
		  (dnsd-log (syslog-level info)
			    "Warning (re)loading zone ~S. Domain ~S contains a CNAME-RR and other RRs at the same time."
			    zone-name key)
		  (if (not (= 1 (length e)))
		      (dnsd-log (syslog-level info)
				"Warning (re)loading zone ~S. Domain ~S contains 2 or more CNAME-RRs!"
				zone-name key))))
	    rr-table))))
   (db-zone-table def-table)))


;; This functions have to be called in the given order:
;; TYPE: db-def-table x string x soa-rr -> unspecific
(define (dbi-set-zone-requirements def-table zone-name soa-rr)
  (dbi-mark-glue-in-zone def-table zone-name)
  (dbi-ensure-min-ttl def-table soa-rr)
  (dbi-cname-warning def-table zone-name))


;; Adds a list of resource-records to a zone-definition-table:
(define (dbi-add-zone-list def-table rr-list)
  (let ((tree (db-zone-table def-table)))
    (for-each
     (lambda (e)
       (let* ((domain-key (make-key-name (resource-record-name e)))
	      (type-key (message-type-name (resource-record-type e)))
	      (rr-type (table-ref tree domain-key)))
	 ;; Create & link a new rr-table for the first entry of the rr-type:
	 (if (not (db-rr-table? rr-type))
	     (begin (set! rr-type (make-db-rr-table))
		    (table-set! tree domain-key rr-type)))
	 (let* ((rr-table (db-rr-table-hash-table rr-type))
		(entry (table-ref rr-table type-key)))
	   (if entry 
	       (table-set! rr-table type-key (cons e entry))
	       (table-set! rr-table type-key (cons e '()))))))
     rr-list)))


;; Adds a zone to the database which is given as a list of resource-records.
;; Notes: * db-add-zone doesn't overwrite existing zones.
;;        * Just for internal use.
;; TYPE: list-of-rrs -> boolean
(define (db-add-zone zone-list)
  (with-r/W-lock 
   (db-class-table-r/w-lock *database*)
   (lambda ()
     (and-let* ((soa-rr (maybe-get-soa-rr zone-list))
		(zone-name (resource-record-name soa-rr))
		(zone-key (make-key-name zone-name))
		(zone-class (resource-record-class soa-rr)))
       ;; Add another class to the database?
       (dbi-maybe-add-class zone-class)
       ;; Get the zone-stuff to insert the zone into together:
       (let* ((zone-table (db-zones-table-hash-table 
			   (table-ref (db-class-table-hash-table *database*)
				      (message-class-name zone-class)))))
	 ;; Don't overwrite an existing zone
	 (if (table-ref zone-table zone-key) #f
	     ;; Add the zone to the db & ensure data integrity:
	     (let* ((zone-dtable (make-db-zone zone-key soa-rr)))
	       (table-set! zone-table zone-key zone-dtable)
	       (dbi-add-zone-list zone-dtable zone-list)
	       (dbi-set-zone-requirements zone-dtable zone-name soa-rr))))))))


;; Update a zone if the serial of the new soa isn't the same or less.
;; TYPE: list-of-rrs -> boolean
(define (db-update-zone zone-list)
  (and-let* ((new-soa-rr (maybe-get-soa-rr zone-list))
	     (new-serial (resource-record-data-soa-serial
			  (resource-record-data new-soa-rr)))
	     (zone-name (make-key-name (resource-record-name new-soa-rr)))
	     (zone-class (resource-record-class new-soa-rr)))
    (let ((old-soa-rr (db-get-zone-soa-rr zone-name zone-class)))
      (cond
       ((or (not old-soa-rr)
	    (and old-soa-rr
		 (> new-serial (resource-record-data-soa-serial
				(resource-record-data old-soa-rr)))))
	(db-clear-zone zone-name zone-class)
	(db-add-zone zone-list))
       ((= new-serial (resource-record-data-soa-serial
		       (resource-record-data old-soa-rr)))
	#t) ;; !!! If the serial hasn't changed it's considered successfull.
       (else #f)))))


; Get all resource records for a zone.
; TYPE: string x message-class -> list-of-rrs or #f
(define (db-get-zone name class)
  (with-R/w-lock 
   (db-class-table-r/w-lock *database*)
   (lambda ()
     (and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
				      (message-class-name class)))
		(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
					  (make-key-name name)))
		(zone-tree-tree (db-zone-table the-zone-type))
		(res-list '()))
       (table-walk
	(lambda (k e)
	  (if e
	      (table-walk (lambda (k1 e1)
			    (set! res-list (append e1 res-list)))
			  (db-rr-table-hash-table e))))
	zone-tree-tree)
       res-list))))


; ; Get the timestamp for a zone.
; ; TYPE: string x message-class -> number or #f
; (define (db-get-zone-timestamp name class)
;   (with-R/w-lock
;    (db-class-table-r/w-lock *database*)
;    (lambda ()
;      (and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
; 				      (message-class-name class)))
; 		(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
; 					  (make-key-name name))))
;        (get-db-zone-timestamp the-zone-type)))))


;; Get the soa-rr of a zone.
;; TYPE: string x message-class -> soa-rr or #f
(define (db-get-zone-soa-rr name class)
  (with-R/w-lock 
   (db-class-table-r/w-lock *database*)
   (lambda ()
     (and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
				      (message-class-name class)))
		(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
					  (make-key-name name))))
       (get-db-zone-soa-rr the-zone-type)))))
	    

; Get all rrs of a zone in an AXFR-ready list: '(soa-rr rr rr ... rr soa-rr)
; TYPE: string x message-class -> list-of-rrs or #f
(define (db-get-zone-for-axfr name class)
  (and-let* ((zone-list (db-get-zone name class))
	     (soa-l (list (maybe-get-soa-rr zone-list)))
	     (rest-l (get-zone-list-w/o-soa zone-list)))
    (append soa-l rest-l soa-l)))


;; Look for the zone in which 'name' is a subdomain or the domain of the
;; given zones. Returns the zone which is the nearest ancestor to 'name'.
;; TYPE: name x message-class -> db-zone-record-type or #f
(define (dbi-lookup-zone-for-name name class)
  (and-let* ((zone-record (table-ref (db-class-table-hash-table *database*)
				     (message-class-name class)))
	     (zone-table (db-zones-table-hash-table zone-record))
	     (ancestors '())
	     (zone-key ""))
    ;; Look for zones who are ancestors to key:
    (table-walk (lambda (k e) 
		  (if (string-ci-zone-name=? k (make-key-name name))
		      (set! ancestors (cons k ancestors))))
		zone-table)
    (cond 
     ((null? ancestors) #f)
     ((= 1 (length ancestors)) (set! zone-key (car ancestors)))
     ;; If more ancestors are found get the closest one:
     (else (set! zone-key (fold-right (lambda (a b) (if (< (string-length a)
							   (string-length b))
							b a))
				      "" ancestors))))
    (table-ref zone-table zone-key)))


; Look for the entries of type 'type' in a given db-rr-table
; TYPE: db-rr-table-rec-type x message-type -> list-of-rrs
(define (dbi-lookup-rrs rr-record-type type)
  (let ((rr-table (db-rr-table-hash-table rr-record-type)))
    (cond
     ((eq? (message-type *) type)  ; ... return all records.
      (let ((res '())) (table-walk (lambda (k e) (set! res (cons e res)))
				   rr-table)
	   res))
     (else (let ((res (table-ref rr-table (message-type-name type))))
	     (if res res '()))))))


;; Look for the entries of type 'type' in a given db-rr-table
;; TYPE: db-rr-table-rec-type x messag-type -> list-of-rrs or #f
(define (dbi-lookup-rrs? rr-record-type type)
  (let ((res (dbi-lookup-rrs rr-record-type type)))
    (if (null? res) #f res)))


;; --------------------------------
;; --- Query/Database Interface ---
;; --------------------------------

;; Requests for mailbox-related resource-records will be handled as mx requests:
;; TYPE: string x type x class ->
;; '(list-of-answers-rrs list-of-nameservers-rrs list-of-additional-rrs boolean)
(define (db-lookup-rec qname class type)
  (obtain-R/w-lock (db-class-table-r/w-lock *database*))
  (receive
   (anli auli adli aufl)
   (dbi-lookup-rec-int qname class (if (eq? type (message-type mailb))
				       (message-type mx)
				       type) ; Mailb == mx query
		       '())
   (release-R/w-lock (db-class-table-r/w-lock *database*))
   (values anli auli adli aufl)))
  

;; Main part of the algorithm as described in RFC 1034. Returns found rrs and
;; a flag, indicating if the answer is authoritative.
;; The flag ist needed, because of glue-data, that could be part of the
;; response. The operand 'c-list' is used to detect and avoid cname-loops.
;; TYPE: string x type x class x c-list ->
;; '(list-of-answers-rrs list-of-nameservers-rrs list-of-additional-rrs boolean)
(define (dbi-lookup-rec-int qname class type c-list)
  (let ((zone (dbi-lookup-zone-for-name qname class)))
    (if (not zone)
	(values '() '() '() #f) ; no zone in db
	(let ((zone-name (db-zone-name zone)))
	  ;; loop over the labels of the name. eg. my.example. / example. / .
	  ;; keep track of the iterations (mostly for wildcard-match support)
	  (let loop ((name qname) (loop-count 0))
	    (let ((rr-table (table-ref (db-zone-table zone) 
				       (make-key-name name))))
	      (if rr-table
		  (cond
		   ;; A wildcard match
		   ((= 1 loop-count)
		    ;; Set the name of the rrs from * to qname.
		    (values (map (lambda (e) (duplicate-rr qname e))
				 (dbi-lookup-rrs rr-table type)) '() '() #t))
		   ;; Direct match (0) or glue-data match (>1)
		   ((or (= 0 loop-count) (< 1 loop-count))
		    (cond ;c2
		     ;; Found glue data.
		     ((and (dbi-lookup-rrs? rr-table (message-type ns))
			   (not (string-ci=? name zone-name))
			   (not (eq? (message-type ns) type)))
		      (let* ((ns-rr-list (dbi-lookup-rrs? 
					  rr-table (message-type ns)))
			     (res-l
			      (fold-right
			       (lambda (e l)
				 (receive
				  (anli auli adli aufl)
				  (dbi-lookup-rec-int
				   (resource-record-data-ns-name
				    (resource-record-data e))
				   class (message-type a) c-list)
				  (list (car l) (cadr l) 
					(append anli (caddr l)) #f)))
			       '(() () () #t) ns-rr-list)))
			(values (car res-l) (append ns-rr-list (cadr res-l))
				(caddr res-l) #f)))
		     ;; Looking for correct information (direct match)
		     ((= 0 loop-count)
		      (cond ;c3
		       ;; CNAME: Causes an additional lookup
		       ((dbi-lookup-rrs? rr-table (message-type cname))
			=> (lambda (cname-rr-list)
			     (let ((cname-rr (car cname-rr-list)))
			       (if (eq? (message-type cname) type)
				   (values (list cname-rr) '() '() #t)
				   (begin
				     (if (fold-right
					  (lambda (e b)
					    (or (string-ci=? e name) b))
					  #f c-list)
					 (begin
					   ;; Problem?: The loop will be send
					   ;; as a response... .
					   (display-debug " Found cname-loop")
					   (values '() '() '() #t))
					 (receive 
					  (anli auli adli aufl)
					  (dbi-lookup-rec-int
					   (resource-record-data-cname-name
					    (resource-record-data cname-rr))
					   class type (cons name c-list))
					  (values (append (list cname-rr) anli)
						  auli adli 
						  (and aufl #t)))))))))
		       ;; MX: Causes an additional lookup
		       ((eq? (message-type mx) type)
			(let* ((mx-rrs (dbi-lookup-rrs rr-table type))
			       (res-l
				(fold-right
				 (lambda (e l)
				   (receive 
				    (anli auli adli aufl)
				    (dbi-lookup-rec-int
				     (resource-record-data-mx-exchanger
				      (resource-record-data e))
				     class (message-type a) c-list)
				    (list (car l) (cadr l) 
					  (append anli (caddr l))
					  (and #t (cadddr l)))))
				 '(() () () #t) mx-rrs)))
			  (values (append mx-rrs (car res-l)) (cadr res-l)
				  (caddr res-l) (and #t (cadddr res-l)))))
		       ;; Glue-Data entries aren't authoritative:
		       ((db-rr-table-glue-data? rr-table)
			(values (dbi-lookup-rrs rr-table type) '() '() #f))
		       ;; Found a match with no additional lookups.
		       (else 
			(values (dbi-lookup-rrs rr-table type) '() '() #t))))
		     ;; Got a dns-name-error (RCODE=3)
		     (else (values '() '() '() #t)))))
		  ;; Found no match for the current name.
		  (cond
		   ((> (string-length zone-name) (string-length name))
		    (error "Woh, found a bug... ")) ; Just for safety...
		   ;; Search for wildcards in the first iteration:
		   ((= 0 loop-count) 
		    (loop (string-append "*." (cut-name name)) 1))
		   (else (loop (cut-name name) (+ 1 loop-count)))))))))))
  

;; ------------------------------
;; --- Database pretty-print: ---
;; ------------------------------

(define (pretty-print-record-type rt)
  (cond
   ((db-class-table? rt)
    (table-walk 
     (lambda (k e)
       (newline)
       (display "DB-Class: ")
       (display k)(newline)
       (pretty-print-record-type e))
     (db-class-table-hash-table rt)))
   ((db-zones-table? rt)
    (table-walk
     (lambda (k e)
       (display " DB-Zone: ")
       (display k)
       (newline)
       (pretty-print-record-type e))
     (db-zones-table-hash-table rt)))
   ((db-zone? rt)
    (table-walk
     (lambda (k e)
       (display "  DB-Zone-Entries: ")
       (display k)
       (newline)
       (pretty-print-record-type e))
     (db-zone-table rt)))
   ((db-rr-table? rt)
    (table-walk
     (lambda (k e)
       (display "   DB-RR-Table: ")
       (display k)
       (newline)
       (display "     Glue-data: ")
       (display (db-rr-table-glue-data? rt))
       (newline)
       (newline)
       (pretty-print-record-type e))
     (db-rr-table-hash-table rt)))
   ((list? rt)
    (for-each 
     (lambda (e)
       (pretty-print-dns-message e)
       (newline))
     rt))
   (else (newline))))

(define (db-pretty-print)
  (with-R/w-lock 
   (db-class-table-r/w-lock *database*)
   (lambda ()
     (newline)
     (display "DNS-Server-Database:")(newline)
     (display "--------------------")(newline)
     (pretty-print-record-type *database*))))