;;****************************************************************************
;;FILE:               dns.lisp
;;LANGUAGE:           Common-Lisp
;;SYSTEM:             Common-Lisp
;;USER-INTERFACE:     NONE
;;DESCRIPTION
;;    
;;    This package gather domain name records and generate zone files and
;;    zone configuration files for named.
;;    
;;AUTHORS
;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;MODIFICATIONS
;;    2004-07-01 <PJB> Added the notion of zone.
;;    2004-06-30 <PJB> Added documentation strings.
;;    2004-06-22 <PJB> Added this header.
;;BUGS
;;LEGAL
;;    GPL
;;    
;;    Copyright Pascal Bourguignon 2004 - 2004
;;    
;;    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
;;****************************************************************************


;; Principles
;; 
;; - domain  struct
;; - zone    (domain[soa], set of domain)
;; 
;; - path (name ...)                 [top to bottom]
;; (arpa in-addr 1 2 3 4)
;; 
;; - fqdn   "name.name.tld"
;; "4.3.2.1.in-addr.arpa"
;; 
;; Paths and FQDN are always considered absolute, so we don't need to append 
;; a dot to the FQDN or to prepend a || to the paths.


;; domain --> list of soa
;; soa --> zone = list of domain under the zone (not in another soa).


(SETQ *PRINT-CIRCLE* T)


;;;------------------------------------------------------------------------
;;; Some functions extracted from com.informatimago.common-lisp.utility
;;;                               com.informatimago.common-lisp.lisp
;;;                           and com.informatimago.common-lisp.string
;;;------------------------------------------------------------------------


(DEFMACRO WHILE (CONDITION &BODY BODY) `(DO () ((NOT ,CONDITION)) ,@BODY))


(DEFUN LIST-INSERT-SEPARATOR (LIST SEPARATOR)
  "
RETURN:  A list composed of all the elements in `list'
         with `separator' in-between.
EXAMPLE: (list-insert-separator '(a b (d e f)  c) 'x)
         ==> (a x b x (d e f) x c)
"
  (DO ((RESULT (IF LIST (LIST (CAR LIST))))
       (LIST (CDR LIST) (CDR LIST)))
      ((NULL LIST) (NREVERSE RESULT))
    (PUSH SEPARATOR RESULT)
    (PUSH (CAR LIST) RESULT)))


(DEFUN LIST->STRING (LIST &KEY (UPCASE NIL))
  "
LIST:   A list of STRING, SYMBOL or CHARACTER.
RETURN: A string formed by the concatenation of all items from LIST.
        If UPCASE then the string is upcased else it's downcased.
"
  (APPLY (FUNCTION CONCATENATE) 'STRING 
         (MAPCAR (LAMBDA (ITEM)
                   (FUNCALL (IF UPCASE 
                                (FUNCTION STRING-UPCASE)
                                (FUNCTION STRING-DOWNCASE))
                            (STRING ITEM))) LIST)))


(DEFUN COMBINE (&REST ARGS)
  "
RETURN:  (elt args 0) x (elt args 1) x ... x (elt args (1- (length args)))
         = the set of tuples built taking one item in order from each list
           in args.
EXAMPLE: (COMBINE '(WWW FTP) '(EXA) '(COM ORG))) 
           --> ((WWW EXA COM) (WWW EXA ORG) (FTP EXA COM) (FTP EXA ORG))
"
  (COND
    ((NULL ARGS) '(NIL))
    ((NULL (CAR ARGS)) (APPLY (FUNCTION COMBINE) (CDR ARGS)))
    ((CONSP (CAR ARGS))
     (MAPCAN (LAMBDA (ITEM) (APPLY (FUNCTION COMBINE) ITEM (CDR ARGS)))
             (CAR ARGS)))
    (T
     (MAPCAN (LAMBDA (REST) (LIST (CONS (CAR ARGS) REST)))
             (APPLY (FUNCTION COMBINE) (CDR ARGS))))))

(defun combine-names (&rest args)
 (mapcar (lambda (args) (apply (function name-append) args))
         (apply (function combine) args)))


(DEFUN CHAR-OR-STRING-P (OBJECT)
  (OR (CHARACTERP OBJECT) (STRINGP OBJECT)))


(DEFUN PJB-UNSPLIT-STRING (STRING-LIST &REST SEPARATOR)
  "Does the inverse than pjb-split-string. If no separator is provided 
then a simple space is used."
  (COND
    ((NULL SEPARATOR)         (SETQ SEPARATOR " "))
    ((/= 1 (LENGTH SEPARATOR)) 
     (ERROR "pjb-unsplit-string: Too many separator arguments."))
    ((NOT (CHAR-OR-STRING-P (CAR SEPARATOR)))
     (ERROR "pjb-unsplit-string: separator must be a string or a char."))
    (T (SETQ SEPARATOR (CAR SEPARATOR))))
  (APPLY 'CONCATENATE 'STRING
         (MAPCAR (LAMBDA (OBJECT)
                   (IF (STRINGP OBJECT) 
                       OBJECT
                       (FORMAT NIL "~A" OBJECT)))
                 (LIST-INSERT-SEPARATOR STRING-LIST SEPARATOR))))


(DEFUN PJB-SPLIT-STRING (STRING &OPTIONAL SEPARATORS)
  "
note:   current implementation only accepts as separators
        a string containing only one character.
"
  (SETQ SEPARATORS (OR SEPARATORS " ")
        STRING (STRING STRING))
  (LET ((SEP (AREF SEPARATORS 0))
        (CHUNKS  '())
        (POSITION 0)
        (NEXTPOS  0)
        (STRLEN   (LENGTH STRING)) )
    (LOOP :WHILE (<= POSITION STRLEN) :DO
       (LOOP :WHILE (AND (< NEXTPOS STRLEN)
                         (CHAR/= SEP (AREF STRING NEXTPOS))) :DO
          (SETQ NEXTPOS (1+ NEXTPOS)))
       (SETQ CHUNKS (CONS (SUBSEQ STRING POSITION NEXTPOS) CHUNKS))
       (SETQ POSITION (1+ NEXTPOS))
       (SETQ NEXTPOS  POSITION) )
    (NREVERSE CHUNKS)))



;;;------------------------------------------------------------------------
;;; The serial time stamp generator
;;;------------------------------------------------------------------------



(DEFUN TODAY ()
  "
RETURN:  A string containing the date of today formated as YYYYMMDD
"
  (MULTIPLE-VALUE-BIND (SEC MIN HOU DAY MON YEA) (GET-DECODED-TIME)
    (DECLARE (IGNORE SEC MIN HOU))
    (FORMAT NIL "~4,'0D~2,'0D~2,'0D" YEA MON DAY)))


(DEFUN NEXT-SERIAL (FILE)
  "
RETURN:  A string containing a serial number formated as YYYYMMDDSS.
POST:    The serial number is incremented and the file is updated.
"
  (WITH-OPEN-FILE (SDF FILE
                       :DIRECTION :IO
                       :IF-EXISTS :APPEND
                       :IF-DOES-NOT-EXIST :CREATE)
    (FILE-POSITION SDF 0)
    (LET* ((TODAY  (TODAY))
           (DATE   (IF SDF (READ SDF NIL TODAY) TODAY))
           (SERIAL (IF SDF (READ SDF NIL 0) 0)))
      (IF (STRING-EQUAL TODAY DATE)
          (INCF SERIAL)
          (SETQ DATE TODAY SERIAL 0))
      (FILE-POSITION SDF 0)
      (FORMAT SDF "~S ~D~2%" DATE SERIAL)
      (FORMAT NIL "~A~2,'0D" DATE SERIAL))))


;;;------------------------------------------------------------------------
;;; Some utility function specific to DNS.
;;;------------------------------------------------------------------------

(DEFUN IPV4-ADDRESS-P (ADDRESS)
  "
RETURN:  Whether ADDRESS has the aaa.bbb.ccc.ddd IPv4 address format.
NOTE:    Actually returns a list (ddd ccc bbb aaa) or NIL; see ADDRESS-TO-BYTES.
"
  (LET ((BYTES (PJB-SPLIT-STRING (STRING ADDRESS) ".")))
    (AND (= 4 (LENGTH BYTES))
         (BLOCK :CONVERT
           (NREVERSE
            (MAPCAR (LAMBDA (BYTE)
                      (MULTIPLE-VALUE-BIND (VAL EATEN) (READ-FROM-STRING BYTE)
                        (IF (AND (= EATEN (LENGTH BYTE)) (INTEGERP VAL) 
                                 (<= 0 VAL 255))
                            VAL
                            (RETURN-FROM :CONVERT NIL))))
                    (PJB-SPLIT-STRING ADDRESS ".")))))))
   

(DEFUN ADDRESS-TO-BYTES (ADDRESS)
  "
PRE:        (IPv4-address-p address)
RETURN:     A list of 4 integer in little endian order.
SEE ALSO:   BYTES-TO-ADDRESS, the inverse function.
EXAMPLE:    (ADDRESS-TO-BYTES  '11.22.33.44) --> (44 33 22 11)
"
  (LET ((RESULT (IPV4-ADDRESS-P ADDRESS)))
    (ASSERT RESULT)
    RESULT))


(DEFUN BYTES-TO-ADDRESS (BYTE-LIST)
  "
PRE:        (and (listp byte-list) (= 4 (length byte-list))
                 (every (lambda (x) (and (integerp x) (<= 0 x 255))) byte-list))
RETURN:     A string concatenating all the elements of BYTE-LIST with a dot
            as separator.
SEE ALSO:   ADDRESS-TO-BYTES, the inverse function.
EXAMPLE:    (BYTES-TO-ADDRESS '(11 22 33 44)) --> ''44.33.22.11''
"
  (ASSERT (AND (LISTP BYTE-LIST) (= 4 (LENGTH BYTE-LIST))
               (EVERY (LAMBDA (X) (AND (INTEGERP X) (<= 0 X 255))) BYTE-LIST)))
  (FORMAT NIL "~{~A~^.~}" (REVERSE BYTE-LIST)))


(DEFUN PATHP (PATH)
  "
RETURN:     Whether PATH is a list encoding a fqdn.
"
  (AND 
   (LISTP PATH)
   (EVERY (LAMBDA (ITEM) (OR (STRINGP ITEM) (SYMBOLP ITEM) (INTEGERP ITEM))) PATH)
   (OR (NULL PATH) 
       (AND (OR (STRINGP (FIRST PATH)) (SYMBOLP (FIRST PATH)))
            (< 1 (LENGTH (STRING (FIRST PATH)))))))) ;;PATHP


(DEFUN IPV4-TO-PATH (IP-STRING)
  "
IP-STRING:  A string or symbol containing an IPv4 address (quad-byte).
RETURN:     A list of string or symbol in the top to bottom order,
            containing 'ARPA, 'IN-ADDR, and the bytes of the IPv4 address.
EXAMPLE:    (IPV4-TO-PATH '1.2.3.4) --> (ARPA IN-ADDR ''1'' ''2'' ''3'' ''4'')
"
  (APPEND (LIST 'ARPA 'IN-ADDR) (PJB-SPLIT-STRING IP-STRING ".")))


(DEFUN DOMAIN-ALPHA-CHAR-P (CH)
  "
NOTE:   We cannot rely on COMMON-LISP:ALPHA-CHAR-P because COMMON-LISP allows
        implementations to add other characters as alphabetic characters.
        (And indeed, accented letters for example are ALPHA-CHAR-P).
NOTE:   We don't assume ASCII, but we assume the domain names we're 
        processing are converted to the standard character set.
"
  (POSITION (CHAR-UPCASE CH) "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))


(DEFUN DOMAIN-ALPHANUMERICP (CH)
  "
NOTE:   We cannot rely on COMMON-LISP:ALPHANUMERICP because COMMON-LISP allows
        implementations to add other characters as alphanumeric characters.
        (And indeed, accented letters for example are ALPHANUMERICP).
NOTE:   We don't assume ASCII, but we assume the domain names we're 
        processing are converted to the standard character set.
"
  (POSITION (CHAR-UPCASE CH) "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"))


(DEFUN FQDN-P (ITEM)
  "
RETURN:   ITEM is a string or symbol denoting a full-qualified domain name.
"
  (AND (OR (STRINGP ITEM) (SYMBOLP ITEM))
       (LET* ((ITEM (STRING ITEM))
              (WORDS (PJB-SPLIT-STRING (IF (CHAR= (CHAR ITEM (1- (LENGTH ITEM)))
                                                  (CHARACTER "."))
                                           (SUBSEQ ITEM 0 (1- (LENGTH ITEM)))
                                           ITEM) ".")))
         (AND (< 1 (LENGTH WORDS))
              (SOME (FUNCTION DOMAIN-ALPHA-CHAR-P) ITEM)
              (EVERY (LAMBDA (WORD) 
                       (AND (<= 1 (LENGTH WORD))
                            (EVERY (LAMBDA (CH)
                                     (OR (CHAR= (CHARACTER "-") CH)
                                         (DOMAIN-ALPHANUMERICP CH))) WORD)))
                     WORDS)))))


(DEFUN FQDN-TO-PATH (FQDN-STRING)
  "
PRE:        (FQDN-P FQDN-STRING)
POST:       (PATHP (FQDN-TO-PATH FQDN-STRING))
EXAMPLE:    (FQDN-TO-PATH 'WWW.INFORMATIMAGO.COM)  --> (COM INFORMATIMAGO WWW)
EXAMPLE:    (FQDN-TO-PATH 'WWW.INFORMATIMAGO.COM.) --> (COM INFORMATIMAGO WWW)
"
  (LET ((PATH (NREVERSE
               (MAPCAR (FUNCTION INTERN)
                       (PJB-SPLIT-STRING (STRING-UPCASE FQDN-STRING) ".")))))
    (WHEN (EQ '|| (CAR PATH)) (POP PATH))
    PATH))
  

(DEFUN PATH-TO-FQDN (PATH)
  "
PATH:       A list of string or symbol in the top to bottom order.
RETURN:     A string containing the domain name encoded in PATH.
EXAMPLE:    (PATH-TO-FQDN '(com example www)) --> ''www.example.com.''
"
  (STRING-DOWNCASE (PJB-UNSPLIT-STRING 
                    (MAPCAR (FUNCTION STRING) (REVERSE (CONS '|| PATH))) ".")))


(DEFUN PATH-TO-ZONE-FILENAME (PATH)
  "
PRE:        (PATHP PATH)
EXAMPLE:    (PATH-TO-ZONE-FILENAME '(COM INFORMATIMAGO WWW))
                --> ''zone.com.informatimago.www''
"
  (STRING-DOWNCASE (PJB-UNSPLIT-STRING 
                    (MAPCAR (FUNCTION STRING) (CONS 'ZONE PATH)) ".")))


(DEFUN ZIP-LISTS (&REST LISTS)
  "(ZIP-LISTS '(a b c) '(1 2 3) ...) --> ((a 1 ...) (b 2 ...) (c 3 ...))"
  (APPLY (FUNCTION MAPCAR) (FUNCTION LIST) LISTS))


(DEFUN MAKE-ADDRESS-SEQ (ADDRESS COUNT)
  "
ADDRESS:    A string or symbol denoting an IPv4 address such as: 
            ''195.114.85.131'' 
            or an in-addr domain such as: ''131.85.114.195.in-addr.arpa'',
            or a list in which at least the first element is a byte integer.
RETURN:     A list of COUNT addresses starting from ADDRESS and incrementing.
EXAMPLE: (MAKE-ADDRESS-SEQ '1.2.3.1 3) --> (''1.2.3.1'' ''1.2.3.2'' ''1.2.3.3'')
"
  (WHEN (SYMBOLP ADDRESS) (SETF ADDRESS (STRING ADDRESS)))
  (LET ((DO-UNSPLIT NIL))
    (LET ((BYTES (COND ((AND (LISTP ADDRESS) (NUMBERP (CAR ADDRESS)))  ADDRESS)
                       ((STRINGP ADDRESS)
                        (SETQ DO-UNSPLIT T)
                        (ADDRESS-TO-BYTES ADDRESS))
                       (T (ERROR "ADDRESS must be a list of byte integers ~
                                  or a string, not ~S" ADDRESS)))))
      (IF (< 0 COUNT)
          (DO ((RESULT (LIST BYTES))
               (COUNT (1- COUNT) (1- COUNT)))
              ((<= COUNT 0) 
               (NREVERSE (IF DO-UNSPLIT
                             (MAPCAR (FUNCTION BYTES-TO-ADDRESS) RESULT) 
                             RESULT)))
            (SETQ BYTES (CONS (1+ (CAR BYTES)) (CDR BYTES)))
            (PUSH BYTES RESULT) )
          NIL))))


(DEFUN MAKE-NAME-SEQ (FORMAT MIN MAX) 
  "
RETURN:  A list of (- max min -1) strings such as:
         (elt result i) == (format nil format (+ i min))
EXAMPLE: (MAKE-NAME-SEQ ''K-~D'' 1 4) --> (''K-1'' ''K-2'' ''K-3'' ''K-4'')
"
  (DO ((RESULT '())
       (MIN MIN (1+ MIN)))
      ((< MAX MIN) (NREVERSE RESULT))
    (PUSH (FORMAT NIL FORMAT MIN)   RESULT)))


(DEFUN ZIP-WITH-ADDRESS-SEQ (NAME-LIST BASE-ADDRESS)
  "
NAME-LIST:    (name ...)
BASE-ADDRESS: A symbol or string denoting an IPv4 address.
RETURN:       ((name address) ...).
"
  (ZIP-LISTS NAME-LIST  (MAKE-ADDRESS-SEQ BASE-ADDRESS (LENGTH NAME-LIST))))


(DEFUN COMPARE-NUMBER-LIST (A B)
  "
DO:         Compare A and B, two list of numbers. 
            The most significant number first.
RETURN:     -1,0 or +1 for a<b, a=b, a>b
"
  (DO () ((NOT (AND A B (= (CAR A) (CAR B)))))
    (SETQ A (CDR A) B (CDR B)))
  (COND
    ((NULL A) (IF (NULL B) 0 -1))
    ((NULL B) 1)
    ((< (CAR A) (CAR B)) -1)
    (T 1)))


(DEFUN NUMBER-LIST-LESSP (A B)
  "
RETURN:  Whether A < B.
"
  (< (COMPARE-NUMBER-LIST A B) 0))


(DEFUN ZIPPED-ADDRESS-LESSP (A B)
  (LET ((BA (ADDRESS-TO-BYTES (SECOND A)))
        (BB (ADDRESS-TO-BYTES (SECOND B))))
    (COND
      ((< (LENGTH BA) (LENGTH BB)) T)
      ((> (LENGTH BA) (LENGTH BB)) NIL)
      (T (NUMBER-LIST-LESSP (NREVERSE BA) (NREVERSE BB))))))


(DEFUN SPLIT-IN-ADDR (ZIPPED-LIST)
  "
ZIPPED-LIST:    A list of lists whose second item is an IPv4 address as
                a 4-byte list in little endian order.
RETURN:         A list of zipped-lists, of which all the elements belong 
                to the same /24 subnet.
"
  (SETF ZIPPED-LIST (SORT ZIPPED-LIST 
                          (LAMBDA (A B)
                            (< 0 (COMPARE-NUMBER-LIST (REVERSE (SECOND A))
                                                      (REVERSE (SECOND B)))))))
  (DO ((RESULT '())
       (CURRENT-ZL (LIST (CAR ZIPPED-LIST)))
       (CURRENT-NA (SECOND (CAR ZIPPED-LIST)))
       (ZIPPED-LIST (CDR ZIPPED-LIST) (CDR ZIPPED-LIST)))
      ((NULL ZIPPED-LIST) (PROGN (PUSH (NREVERSE CURRENT-ZL) RESULT)
                                 (NREVERSE RESULT)))
    (IF (= 0 (COMPARE-NUMBER-LIST 
              (CDR CURRENT-NA) ;; no need for reverse to compare of equality.
              (CDR (SECOND (CAR ZIPPED-LIST)))))
        (PUSH (CAR ZIPPED-LIST) CURRENT-ZL)
        (PROGN
          (PUSH (NREVERSE CURRENT-ZL) RESULT)
          (SETQ CURRENT-ZL (LIST (CAR ZIPPED-LIST))
                CURRENT-NA (SECOND (CAR ZIPPED-LIST)))))))


(DEFUN NAME-APPEND (&REST ARGS)
  "
ARGS:    A list of INTEGER, STRING, SYMBOL or CHARACTER.
RETURN:  An interned symbol, concatenation of all items from ARGS, 
         separated by ''.'' and upcased. 
         If the items start or end with a dot, it's removed.
EXAMPLE: (NAME-APPEND 'WWW. 'EXAMPLE '.COM.) --> WWW.EXAMPLE.COM
"
  (WITH-STANDARD-IO-SYNTAX
    (INTERN
     (STRING-UPCASE
      (DO ((ITEMS 
            (MAPCAR
             (LAMBDA (ITEM)
               (SETQ ITEM (TYPECASE ITEM
                            (INTEGER (FORMAT NIL "~D" ITEM))
                            (LIST    (FORMAT NIL "~A" (EVAL ITEM)))
                            (OTHERWISE (STRING ITEM))))
               (SUBSEQ ITEM
                       (IF (CHAR= (CHARACTER ".") (CHAR ITEM 0)) 1 0)
                       (IF (CHAR= (CHARACTER ".") 
                                  (CHAR ITEM (1- (LENGTH ITEM))))
                           (1- (LENGTH ITEM)) (LENGTH ITEM))))
             ARGS)  (CDR ITEMS))
           (CHUNKS '()))
          ((NULL ITEMS)
           (PROGN (POP CHUNKS)
                  (APPLY (FUNCTION CONCATENATE) 'STRING
                         (NREVERSE CHUNKS))))
        (PUSH (CAR ITEMS) CHUNKS)
        (PUSH "." CHUNKS)) ))))


;;;------------------------------------------------------------------------
;;; DNS Records:
;;;------------------------------------------------------------------------
;;; A DNS Record is a list whose first item is a string or symbol denoting
;;; the type of record, and the following items are the record fields.
;;;


(DEFUN RECORD-TYPE-EQUAL-P (T1 T2)
  "
RETURN:  DNS record type T1 and T2 are the same.
"
  (STRING-EQUAL T1 T2))


(DEFUN RECORD-SOA-P (RECORD)
  "
RETURN:  RECORD is a SOA record.
"
  (RECORD-TYPE-EQUAL-P "SOA" (FIRST RECORD)))


(DEFUN RECORD-NS-P (RECORD)
  "
RETURN:  RECORD is a NS record.
"
  (RECORD-TYPE-EQUAL-P "NS" (FIRST RECORD)))


(DEFUN RECORD-A-P (RECORD)
  "
RETURN:  RECORD is an A record.
"
  (RECORD-TYPE-EQUAL-P "A" (FIRST RECORD)))


(defstruct (record-soa (:type list))
  soa host master serial refresh retry expiry minimum-ttl)
 

;;;------------------------------------------------------------------------
;;; DOMAIN
;;;------------------------------------------------------------------------
;;;
;;; A domain has a name, a full qualified domain name (= a path)
;;; records, a parent and children.
;;; 
;;; A domain includes the whole domain subtree of which it ss the root.
;;;


(DEFSTRUCT (DOMAIN  (:PRINT-OBJECT DOMAIN-PRINT))
  "A Domain Name, with links to its parent, its childrens and its records."
  (NAME) (PARENT) (RECORDS) (CHILDREN) (ALLOW-UPDATE NIL))


;;;------------------------------------------------------------------------
;;; The following functions process the root node of a domain:
;;;------------------------------------------------------------------------


(DEFMETHOD DOMAIN-PRINT (DOMAIN STREAM)
  "
DO:     Prints a DOMAIN.
"
  (FORMAT STREAM
    "<DOMAIN ~A, ~D RECORD~:[~;S~], ~D CHILD~:[~;REN~], ALLOW-UPDATE=~A>"
    (DOMAIN-FQDN DOMAIN)
    (LENGTH (DOMAIN-RECORDS  DOMAIN))(< 1 (LENGTH (DOMAIN-RECORDS  DOMAIN)))
    (LENGTH (DOMAIN-CHILDREN DOMAIN))(< 1 (LENGTH (DOMAIN-CHILDREN DOMAIN)))
    (DOMAIN-ALLOW-UPDATE DOMAIN)))


(DEFUN DOMAIN-PATH (DOMAIN)
  "
RETURN:     A list of string or symbol in the top to bottom order.
EXAMPLE:    (COM INFORMATIAMGO WIFI AP)
"
  (WHEN (DOMAIN-PARENT DOMAIN) 
    (NCONC (DOMAIN-PATH (DOMAIN-PARENT DOMAIN)) (LIST (DOMAIN-NAME DOMAIN)))))
    

(DEFUN DOMAIN-FQDN (DOMAIN)
  "
RETURN:  The full qualified domain name of the node (including root dot).
EXAMPLE: ap.wifi.informatimago.com.
"
  (PATH-TO-FQDN (DOMAIN-PATH DOMAIN)))


(DEFUN DOMAIN-LEAF-P (DOMAIN)
  "
RETURN:  DOMAIN has no child.
"
  (NULL (DOMAIN-CHILDREN DOMAIN)))


(DEFUN DOMAIN-SOA-RECORD (DOMAIN)
  "
RETURN:  The SOA record of the DOMAIN if there's one.
"
  (FIND-IF (FUNCTION RECORD-SOA-P) (DOMAIN-RECORDS DOMAIN)))


(DEFUN DOMAIN-CHILD-NAMED (DOMAIN NAME)
  "
NAME:       A string or symbol denoming a domain name.
CHILDREN:   A list of DOMAIN.
RETURN:     The node in the CHILDREN list whose name is NAME.
"
  (FIND-IF (LAMBDA (CHILD) (STRING-EQUAL (STRING NAME) 
                                         (STRING (DOMAIN-NAME CHILD))))
           (DOMAIN-CHILDREN DOMAIN)))


;;;------------------------------------------------------------------------
;;; The following functions process whole domain subtrees.
;;;------------------------------------------------------------------------


(DEFUN DOMAIN-SUBDOMAIN-AT-PATH (DOMAIN PATH)
  "
PATH:       A list of string or symbol in the top to bottom order.
DOMAIN:     A domain instance.
DO:         Walks down the DOMAIN following the PATH.
RETURN:     The node reached.
"
  (IF (NULL PATH)
      DOMAIN
      (LET ((CHILD  (DOMAIN-CHILD-NAMED DOMAIN (CAR PATH))))
        (IF CHILD
            (DOMAIN-SUBDOMAIN-AT-PATH CHILD (CDR PATH))
            (ERROR "There's no child named ~S in domain ~S." 
                   (CAR PATH) (DOMAIN-FQDN DOMAIN))))))


(DEFUN MAP-DOMAIN-TREE (FUN DOMAIN &OPTIONAL FQDN)
  "
DOMAIN: A DOMAIN instance.
FQDN:   The FQDN of the parent of the DOMAIN.
FUN:    A function taking two arguments: a domain and its FQDN.
DO:     Applies the function FUN on the domain and all its children, 
        recursively. 
"
  (SETQ FQDN (IF FQDN 
                 (FORMAT NIL "~A.~A" (DOMAIN-NAME DOMAIN) FQDN)
                 (DOMAIN-FQDN DOMAIN)))
  (FUNCALL FUN DOMAIN FQDN)
  (MAPCAR (LAMBDA (CHILD) (MAP-DOMAIN-TREE FUN CHILD FQDN)) 
          (DOMAIN-CHILDREN DOMAIN)))


(DEFUN DOMAIN-HANG-RECORD (DOMAIN PATH RECORD)
  "
DOMAIN:     The domain in which subtree the RECORD will be hung.
PATH:       A list of string or symbol in the top to bottom order.
RECORD:     A record to hang to the PATH.
DO:         Attach the RECORD to the domain reached at the PATH.
"
  (IF (NULL PATH)
      ;; found it:
      (PUSHNEW (mapcar (lambda (x)
                         (typecase x
                           ((or symbol string) (string-downcase x))
                           (otherwise           x)))
                       RECORD) (DOMAIN-RECORDS DOMAIN) :test (function equalp))
      ;; not yet, let's walk down the tree:
      (LET ((CHILD (DOMAIN-CHILD-NAMED DOMAIN (CAR PATH))))
        (IF CHILD
            ;; exists already:
            (DOMAIN-HANG-RECORD CHILD (CDR PATH) RECORD)
            ;; does not exist yet:
            (LET ((CHILD (MAKE-DOMAIN :NAME (CAR PATH) :PARENT DOMAIN
                                      :CHILDREN '() :RECORDS '())))
              (PUSH CHILD (DOMAIN-CHILDREN DOMAIN))
              (DOMAIN-HANG-RECORD CHILD (CDR PATH) RECORD))))))


(DEFUN DOMAIN-LIST-ALL-SOA (DOMAIN)
  "
RETURN:  A list of domain instance, children 
"
  (LET ((SOA-DOMAINS '()))
    (MAP-DOMAIN-TREE (LAMBDA (DOMAIN FQDN)
                       (DECLARE (IGNORE FQDN))
                       (WHEN (DOMAIN-SOA-RECORD DOMAIN)
                         (PUSH DOMAIN SOA-DOMAINS)))
                     DOMAIN)
    SOA-DOMAINS))


(DEFUN DOMAIN-ZONE (SOA-DOMAIN)
  (LABELS ((DOMAIN-SUB-ZONE 
               (DOMAIN)
             (UNLESS (DOMAIN-SOA-RECORD DOMAIN)
               (CONS DOMAIN 
                     (MAPCAN (FUNCTION DOMAIN-SUB-ZONE) 
                             (DOMAIN-CHILDREN DOMAIN))))))
    (CONS SOA-DOMAIN 
          (MAPCAN (FUNCTION DOMAIN-SUB-ZONE)
                  (DOMAIN-CHILDREN SOA-DOMAIN)))))


;;;------------------------------------------------------------------------
;;; The domain database
;;;------------------------------------------------------------------------

(DEFVAR *TRACE-DOMAIN* NIL)

(DEFVAR *DOMAINS*
  (MAKE-DOMAIN :NAME '|| :PARENT NIL :RECORDS '() :CHILDREN '())
  "The root of all domains.")


(DEFVAR *REVERSES* '()  
  "A list of (CONS IP-MATCH DOMAIN).
IP-MATCH:   A list of bytes in lsb first order,
            or a predicate of an address (sequence of bytes).
DOMAIN:     A string or symbol denoting a domain name,
            or a function of an address (sequence of bytes).")


(DEFUN RESET ()
  "
DO:     Forget the domains and reverses.
"
  (SETQ *DOMAINS*
        (MAKE-DOMAIN :NAME '|| :PARENT NIL :RECORDS '() :CHILDREN '()))
  (SETQ *REVERSES* NIL)
  (REGISTER-REVERSE NIL 'IN-ADDR.ARPA)
  (VALUES))


(DEFUN REGISTER-REVERSE (IP-MATCH DOMAIN)
  "
IP-MATCH:   A list of bytes in lsb first order,
            or a predicate of an address (sequence of bytes).
DOMAIN:     A string or symbol denoting a domain name,
            or a function of an address (sequence of bytes).
DO:         Register the IP-MATCH with the DOMAIN.
"
  (PUSH (CONS IP-MATCH DOMAIN) *REVERSES*))


(DEFUN REVERSE-DOMAIN-FOR-ADDRESS (ADDRESS)
  "
ADDRESS:    An IPv4 address.
RETURN:     A FQDN ; a DN.
DO:         Finds in *REVERSES* 3 high order bytes matching address and
            returns a name built from the corresponding domain and the address.
            In the case of (nil . in-addr.arpa), all the bytes from address are
            used (10.0.0.131 gives 131.0.0.10.in-addr.arpa.), while for non-nil
            3-bytes lists, only the low-order byte is used
            (195.114.85.131 gives 131.afaa.asso.fr.).
"
  (ASSERT (IPV4-ADDRESS-P ADDRESS))
  (LET* ((BYTES (ADDRESS-TO-BYTES ADDRESS))
         (REV (FIND BYTES *REVERSES*
                    :KEY  (FUNCTION CAR)
                    :TEST (LAMBDA (A B)
                            (COND
                              ((OR (NULL A) (NULL B)))
                              ((FUNCTIONP B) (FUNCALL B A))
                              (T (= 0 (COMPARE-NUMBER-LIST (CDR A) B)))))))
         (QDN (CDR REV)))
    (VALUES
     (IF (FUNCTIONP QDN)
         (FUNCALL QDN BYTES)
         (FORMAT NIL "~A.~A."
                 (IF (CAR REV) (CAR BYTES) (PJB-UNSPLIT-STRING BYTES "."))
                 QDN))
     QDN)))


;;;------------------------------------------------------------------------
;;; Filling the domain database
;;;------------------------------------------------------------------------


(DEFPARAMETER *PRE-PROCESSING-LIST* '()
  "A list of function processing the (name record) args before hanging
the new record in ADD-RECORD.")


(DEFUN ADD-PRE-PROCESSING (FUN)
  "
DO:    Add the function FUN to the *PRE-PROCESSING-LIST*
"
  (PUSH FUN *PRE-PROCESSING-LIST*))


(DEFPARAMETER *POST-PROCESSING-LIST* '() 
  "A list of function processing the (path record) before generating it
in DNS-GENERATE-RECORD.")


(DEFUN ADD-POST-PROCESSING (FUN)
  "
DO:    Add the function FUN to the *POST-PROCESSING-LIST*
"
  (PUSH FUN *POST-PROCESSING-LIST*))


(ADD-PRE-PROCESSING
 (LAMBDA (NAME VALUE)
   "
DO:    This pre-processing converts the NAME to a path (in top to bottom order),
       and removes the root domain from the path if present.
"
   (VALUES
    (LET ((PATH (IF (IPV4-ADDRESS-P NAME)
                    (IPV4-TO-PATH NAME)
                    (FQDN-TO-PATH NAME))))
      (WHEN (EQ '|| (CAR PATH)) (POP PATH))
      PATH)
    VALUE)))



(DEFUN ADD-DOT-IF-NEEDED (ITEM)
  "
PRE:      (OR (STRINGP ITEM) (SYMBOLP ITEM))
RETURN:   If the last character of ITEM  is a dot 
          then ITEM
          else the concatenation of ITEM and a dot.
"
  (SETQ ITEM (STRING ITEM))
  (IF (CHAR= (CHARACTER ".") (CHAR ITEM (1- (LENGTH ITEM))))
      ITEM
      (CONCATENATE 'STRING ITEM ".")))


(ADD-PRE-PROCESSING
 (LAMBDA (PATH RECORD)
   "
PRE:   (LISTP RECORD)
DO:    This post processing normalize the fields of the RECORD
       (all but the first item in the RECORD):
           - number stay as is.
           - IPV4 addresses symbols are converted to IPV4 strings.
           - FQDN get the final dot if needed.
           - symbols are convered to strings.
           - other values are errors.
"
   (VALUES PATH
           (CONS (CAR RECORD)
                 (MAPCAR (LAMBDA (ITEM)
                           (COND 
                             ((NUMBERP ITEM)        ITEM)
                             ((IPV4-ADDRESS-P ITEM) (STRING ITEM))
                             ((FQDN-P ITEM) (ADD-DOT-IF-NEEDED ITEM))
                             ((OR (STRINGP ITEM) (SYMBOLP ITEM)) (STRING ITEM))
                             (T (ERROR "Unexpected field type."))))
                         (CDR RECORD))))))
   

(DEFUN ADD-RECORD (FQDN RECORD &REST OPTIONS)
  "
RECORD: Either a list containing the record type and the fields,
        or an atom representing the address field of an A record.
DO:     Add a record RECORD to the domain fqdn FQDN.
        If OPTIONS contains :INFERIORS, then add the record RECORD to
        the domain fqdn *.FQDN (the inferior domain fqdns).
"
  (WHEN *TRACE-DOMAIN*
    (FORMAT *TRACE-OUTPUT* "(ADD-RECORD ~S ~S~{ ~S~})~%" FQDN RECORD OPTIONS))
  (IF (ATOM RECORD)
      (APPLY (FUNCTION ADD-RECORD) FQDN (LIST 'A  RECORD) OPTIONS)
      (LET ((PATH FQDN)) 
        (DOLIST (PROC *PRE-PROCESSING-LIST*)
          (MULTIPLE-VALUE-SETQ (PATH RECORD) (FUNCALL PROC PATH RECORD)))
        (DOMAIN-HANG-RECORD *DOMAINS* PATH RECORD)
        (WHEN (MEMBER :INFERIORS OPTIONS)
          (DOMAIN-HANG-RECORD *DOMAINS* (APPEND PATH '("*"))  RECORD)) ))
  ;; Check for address domain fqdns missing in-addr.arpa:
  (WHEN (SOME (FUNCTION NUMBERP) ;; some TLD is a number
              (MAPCAR (LAMBDA (ITEM) (IF (AND (STRINGP ITEM) (STRING= "." ITEM))
                                         NIL
                                         (READ-FROM-STRING ITEM)))
                      ;; The list of TLD:
                      (MAPCAR (FUNCTION DOMAIN-FQDN)
                              (DOMAIN-CHILDREN *DOMAINS*))))
    (ERROR "Adding ~S~%" (LIST FQDN RECORD OPTIONS))) )

(defun add-name (NAME ADDRESS)
  "
DO:    Add a  NAME     'IN A'   ADDRESS record 
       and a  PTR-NAME 'IN PTR' NAME record.
       The PTR-NAME is computed from the ADDRESS and the *REVERSES* list.
"
  (LET ((PTR-NAME (REVERSE-DOMAIN-FOR-ADDRESS ADDRESS)) )
    (ADD-RECORD NAME     (LIST 'A   ADDRESS))
    (ADD-RECORD PTR-NAME (LIST 'PTR NAME))))

(DEFMACRO DEFINE-ZONE (DOMAIN SOA-RECORD &REST ADDITIONAL-NS)
  "
DO:     Add a SOA and a NS record, and a set of additional NS record for 
        the additional name servers for the DOMAIN.
"
  `(PROGN
     (ADD-RECORD ,DOMAIN (LIST 'SOA ,@SOA-RECORD))
     (ADD-RECORD ,DOMAIN (LIST 'NS ,(FIRST SOA-RECORD)))
     ,@(MAPCAR (LAMBDA (NS) `(ADD-RECORD ,DOMAIN (LIST 'NS ,NS)))
               ADDITIONAL-NS)))


;;;------------------------------------------------------------------------
;;; Generating zones and configurations.
;;;------------------------------------------------------------------------


(ADD-POST-PROCESSING
 (LAMBDA (NODE RECORD)
   "
DO:     This postprocessing converts all the record items to strings,
        puts the record type in upcase, 
        and either encloses the each field in double-quote if it contains spaces
            or downcases it.
"
   ;; (format *trace-output* "generating node ~S, record ~S~%"
   ;; (domain-fqdn node) record)
   (VALUES NODE 
           (CONS 
            (STRING-UPCASE (FIRST RECORD))
            (MAPCAR 
             (LAMBDA (ITEM)
               (SETQ ITEM (FORMAT NIL "~A" ITEM))
               (SETQ ITEM (IF (POSITION (CHARACTER " ") ITEM)
                              (FORMAT NIL "~S" ITEM)
                              (STRING-DOWNCASE ITEM))))
             (REST RECORD))))))


(DEFUN GENERATE-RECORD (ZONE-STREAM DOMAIN RECORD)
  "
ZONE-STREAM:    A character stream open for output.
DOMAIN:         A domain instance..
RECORD:         A record of the DOMAIN.
DO:             Applies all the post processing functions to the
                (DOMAIN RECORD) couple.  Then writes out on to the
                ZONE-STREAM stream the RECORD for the DOMAIN name.
"
  (LET (RLEN
        TYPE
        FIELDS)
    (DOLIST (PROC *POST-PROCESSING-LIST*)
      (MULTIPLE-VALUE-SETQ (DOMAIN RECORD) (FUNCALL PROC DOMAIN RECORD)))
    (SETQ TYPE (FIRST RECORD) FIELDS (REST RECORD))
    (SETQ RLEN (APPLY (FUNCTION +)
                      (LENGTH FIELDS)
                      (MAPCAR (FUNCTION LENGTH) FIELDS)))
    (IF (OR T (= 1 (LENGTH FIELDS)) (< RLEN 34))
        (FORMAT ZONE-STREAM "~34A IN ~6A ~{~A ~}~%" 
                (DOMAIN-FQDN DOMAIN) TYPE FIELDS)
        (PROGN
          (IF (RECORD-SOA-P RECORD)
              (FORMAT ZONE-STREAM "~34A IN ~6A ~A ~A ( " 
                      (DOMAIN-FQDN DOMAIN) TYPE  (POP FIELDS) (POP FIELDS))
              (FORMAT ZONE-STREAM "~34A IN ~6A ( " 
                      (DOMAIN-FQDN DOMAIN) TYPE))
          (DO ((COL 47)
               (FIELDS FIELDS (CDR FIELDS))
               FIELD)
              ((NULL FIELDS) (FORMAT ZONE-STREAM ")~%"))
            (SETQ FIELD (CAR FIELDS))
            (INCF COL (1+ (LENGTH FIELD)))
            (WHEN (<= 78 COL)
              (FORMAT ZONE-STREAM "~%~47A" "")
              (SETQ COL (+ 48 (LENGTH FIELD))))
            (FORMAT ZONE-STREAM "~A " FIELD))))))


(DEFUN GENERATE-ZONE (DIRPATH SOA-DOMAIN)
  "
DIRPATH:    The pathname of the director where the zone file must be created.
SOA-DOMAIN: The root node of the zone.
DO:         Writes a zone file for this SOA-DOMAIN.
RETURN:     THE pathname of the generated file.
"
  (UNLESS (DOMAIN-SOA-RECORD SOA-DOMAIN)
    (ERROR "Not a SOA domain ~A." SOA-DOMAIN))
  (LET ((FILEPATH (MERGE-PATHNAMES
                   (MAKE-PATHNAME :NAME (PATH-TO-ZONE-FILENAME
                                         (DOMAIN-PATH SOA-DOMAIN)))
                   DIRPATH)))
    (ENSURE-DIRECTORIES-EXIST FILEPATH)
    (WITH-OPEN-FILE (ZONE-STREAM FILEPATH
                                 :DIRECTION :OUTPUT
                                 :IF-EXISTS :SUPERSEDE
                                 :IF-DOES-NOT-EXIST :CREATE)
      (FORMAT *TRACE-OUTPUT* "~&Generating ~A~%" FILEPATH)
      (FORMAT ZONE-STREAM ";; File generated automatically by dns.lisp ~%")
      (FORMAT ZONE-STREAM ";; TAG=~A ~2%" (FILE-NAMESTRING DIRPATH))
      (FORMAT ZONE-STREAM "$TTL ~A~%"
              (RECORD-SOA-minimum-TTL (DOMAIN-SOA-RECORD SOA-DOMAIN)))
      (LET ((RECORDS '()))
        ;; First we gather the records of the zone into records.
        (LABELS ((GENERATE 
                     (DOMAIN)
                   (IF (DOMAIN-SOA-RECORD DOMAIN)
                       ;; Generate A and NS records for NS of sub SOA:
                       (DOLIST (NS (REMOVE-IF (LAMBDA (R) (NOT (RECORD-NS-P R)))
                                              (DOMAIN-RECORDS DOMAIN)))
                         (PUSH (CONS DOMAIN NS) RECORDS)
                         (LET ((NS-DOMAIN (DOMAIN-SUBDOMAIN-AT-PATH 
                                           *DOMAINS* 
                                           (FQDN-TO-PATH (SECOND NS)))))
                           ;; (FORMAT *TRACE-OUTPUT* "~A --(NS)--> ~S~%"
                           ;;         (domain-fqdn domain) ns)
                           ;; (FORMAT *TRACE-OUTPUT* "~A --(A)--> ~S~%"
                           ;;         (domain-fqdn ns-domain)
                           ;;         (remove-if (lambda (r) (not (record-a-p r)))
                           ;;         (DOMAIN-RECORDS ns-domain)))
                           (MAP NIL  
                                (LAMBDA (ADDRESS) 
                                  (PUSH (CONS NS-DOMAIN ADDRESS) RECORDS))
                                (REMOVE-IF (LAMBDA (R) (NOT (RECORD-A-P R)))
                                           (DOMAIN-RECORDS NS-DOMAIN)))))
                       ;; Generate records of domain and children:
                       (PROGN 
                         (MAPC (LAMBDA (REC) (PUSH (CONS DOMAIN REC) RECORDS))
                               (DOMAIN-RECORDS DOMAIN))
                         (MAPC (FUNCTION GENERATE) (DOMAIN-CHILDREN DOMAIN))))))
          (GENERATE SOA-DOMAIN)
          (MAPC (LAMBDA (REC)  (PUSH (CONS SOA-DOMAIN REC) RECORDS))
                (DOMAIN-RECORDS SOA-DOMAIN))
          (MAPC (FUNCTION GENERATE)  (DOMAIN-CHILDREN SOA-DOMAIN)))
        ;; Then we remove duplicate records before writing them to the stream.
        (MAP NIL (LAMBDA (DR) (GENERATE-RECORD ZONE-STREAM (CAR DR) (CDR DR))) 
             (DELETE-DUPLICATES RECORDS :TEST (FUNCTION EQUAL)))))
    FILEPATH))


(DEFUN GENERATE-ZONES (DIRPATH ROOT-DOMAIN)
  "
DIRPATH:        The path of the directory where the zone files are generated.
ROOT-DOMAIN:    The root domain.
DO:             Generate all the zone files for all the SOA domains.
RETURN:         A list of (cons  pathname of the zone file, SOA domain).
"
  (LET ((FILES '()))
    (MAPC (LAMBDA (SOA-DOMAIN)
            (PUSH (CONS (GENERATE-ZONE DIRPATH SOA-DOMAIN) SOA-DOMAIN) 
                  FILES))
          (DOMAIN-LIST-ALL-SOA ROOT-DOMAIN))
    FILES))


(DEFUN GENERATE-ZONE-CONF (SLAVE-DIRPATH FILEPATH TAG LABEL MASTERS FILES)
  "
DIRPATH:    Directory where the zones are stored (slave zones).
FILEPATH:   The path of the zone configuration file to generate.
TAG:        Used as prefix for the name of the directory where the zone
            files are stored. (example: ''public'' or ''intra'').
LABEL:      A string used to name the zone conf file.
MASTERS:    If generating for a slave server
            then list of IP addresses of the master DN servers, 
            else NIL.
FILES:      A list of cons (file-name . domain).
DO:         Generate a file to be included in named.conf defining the zones
            served by the DNS.
NOTE:       The name of the file generated is the concatenation of:
            *CONF-DIRECTORY* ''/zones-'' TAG ''-slave-'' or ''-master-''
            LABEL ''.conf''.
"
  (ENSURE-DIRECTORIES-EXIST FILEPATH)
  (WITH-OPEN-FILE (CONFIG FILEPATH
                          :DIRECTION :OUTPUT
                          :IF-EXISTS :SUPERSEDE
                          :IF-DOES-NOT-EXIST :CREATE)
    (FORMAT *TRACE-OUTPUT* "~&Generating ~A~%" FILEPATH)
    (MULTIPLE-VALUE-BIND (SE MI HO DA MO YE) (GET-DECODED-TIME)
      (FORMAT CONFIG "# File generated automatically by dns.lisp on ~
                      ~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D~%"
              YE MO DA HO MI SE))
    (FORMAT CONFIG "# TAG=~A  LABEL=~A ~%~{# MASTER=~A~%~}~2%" 
            TAG LABEL MASTERS)
    (DOLIST (ITEM FILES)
      (LET ((FILEPATH    (CAR ITEM))
            (DOMAIN      (CDR ITEM)))
        (FORMAT CONFIG "zone ~S IN {~%" (DOMAIN-FQDN DOMAIN))
        (FORMAT CONFIG "    type ~:[slave~;master~];~%" (NOT MASTERS))
        (IF (NULL MASTERS)
            (PROGN ;; We're generating a master zone configuration.
              (FORMAT CONFIG "    file ~S;~%" (NAMESTRING FILEPATH))
              ;; (FORMAT CONFIG "    check-names fail;~%") ;; not implemented!?
              (FORMAT CONFIG "    allow-update   { ~:[none;~;~:*~{~A;~}~] };~%" 
                      (DOMAIN-ALLOW-UPDATE DOMAIN)))
            (PROGN ;; We're generating a slave zone configuration.
              (FORMAT CONFIG "    file ~S;~%"
                      (NAMESTRING
                       (MERGE-PATHNAMES
                        (MAKE-PATHNAME
                         :NAME (CONCATENATE 'STRING "slave-"
                                            (PATH-TO-ZONE-FILENAME
                                             (DOMAIN-PATH DOMAIN))))
                        SLAVE-DIRPATH)))
              (FORMAT CONFIG "    masters { ~{ ~A;~} };~%" MASTERS) ))
        (FORMAT CONFIG "    notify yes;~%")
        (FORMAT CONFIG "    allow-transfer { any; };~%")
        (FORMAT CONFIG "    allow-query    { any; };~%")
        ;; allow-update is not allowed in slave
        (FORMAT CONFIG "};~2%") ))))


(DEFVAR *ZONE-DIR*  (USER-HOMEDIR-PATHNAME))
(DEFVAR *CONF-DIR*  (USER-HOMEDIR-PATHNAME))

(DEFUN GENERATE-FILES (TAG LABEL MASTERS)
  "
TAG:        Used as prefix for the name of the directory where the zone
            files are stored. (example: ''public'' or ''intra'').
LABEL:      A string used to name the zone conf file.
MASTERS:    If generating for a slave server
            then list of IP addresses of the master DN servers, 
            else NIL.
DO:         Generate the zone files for all the *domains*
            and the zone configuration files for a master server
            and a slave server.
"
  (LET* ((MASTER-DIRPATH
          (MERGE-PATHNAMES
           (MAKE-PATHNAME :DIRECTORY  (LIST :RELATIVE
                                            (FORMAT NIL "~A-master" TAG)))
           *ZONE-DIR*))
         (SLAVE-DIRPATH
          (MERGE-PATHNAMES
           (MAKE-PATHNAME :DIRECTORY  (LIST :RELATIVE
                                            (FORMAT NIL "~A-slave" TAG)))
           *ZONE-DIR*))
         (CONF-MASTER-FILEPATH
          (MERGE-PATHNAMES
           (MAKE-PATHNAME :NAME (FORMAT NIL "zones-~A-master-~A" TAG LABEL)
                          :TYPE "conf")
           *CONF-DIR*))
         (CONF-SLAVE-FILEPATH
          (MERGE-PATHNAMES
           (MAKE-PATHNAME :NAME (FORMAT NIL "zones-~A-slave-~A"  TAG LABEL)
                          :TYPE "conf")
           *CONF-DIR*))
         (FILES (GENERATE-ZONES MASTER-DIRPATH *DOMAINS*)))
    (GENERATE-ZONE-CONF SLAVE-DIRPATH ;; master
                        CONF-MASTER-FILEPATH  TAG LABEL NIL     FILES) 
    (GENERATE-ZONE-CONF SLAVE-DIRPATH ;; slave
                        CONF-SLAVE-FILEPATH   TAG LABEL MASTERS FILES)))

        

;;;------------------------------------------------------------------------
;;; Some interactive functions:
;;;------------------------------------------------------------------------

(DEFUN PRINT-DOMAIN-RECORDS (DOMAIN &key (OUTPUT *STANDARD-OUTPUT*) TYPE)
  "
DOMAIN: Either an IPV4 address or a FQDN.
DO:     Write to the  OUTPUT stream the records attached to the DOMAIN.
        If TYPE is given, then writes only records of this type.
"
  (LET ((PATH (IF (IPV4-ADDRESS-P domain)
                  (IPV4-TO-PATH domain)
                  (FQDN-TO-PATH domain))))
    (WHEN (EQ '|| (CAR PATH)) (POP PATH))
    (LET ((NODE (DOMAIN-SUBDOMAIN-AT-PATH *DOMAINS* PATH)))
      (IF TYPE
          (DOLIST (REC (DOMAIN-RECORDS NODE))
            (IF (RECORD-TYPE-EQUAL-P TYPE (CAR REC))
                (GENERATE-RECORD OUTPUT NODE REC)))
          (DOLIST (REC (DOMAIN-RECORDS NODE))
            (GENERATE-RECORD OUTPUT NODE REC))))))



(DEFUN PRINT-DOMAIN-CHILDREN (DOMAIN &key (OUTPUT *STANDARD-OUTPUT*))
  "
DOMAIN: Either an IPV4 address or a FQDN.
DO:     Write to the output stream the FQDN of the direct 
        children of the DOMAIN.
"
  (LET ((PATH (IF (IPV4-ADDRESS-P DOMAIN)
                  (IPV4-TO-PATH DOMAIN)
                  (FQDN-TO-PATH DOMAIN))))
    (WHEN (EQ '|| (CAR PATH)) (POP PATH))
    (LET ((NODE (DOMAIN-SUBDOMAIN-AT-PATH *DOMAINS* PATH)))
      (DOLIST (CHILD (DOMAIN-CHILDREN NODE))
        (FORMAT OUTPUT "~A~%" (DOMAIN-FQDN CHILD))))))


(DEFUN PRINT-DOMAIN-TREE (DOMAIN &key (OUTPUT *STANDARD-OUTPUT*)
                          (dump-records nil) (type nil))
  
  "
DOMAIN: A domain structure.
DO:     Write to the output stream the FQDN of the children of the DOMAIN,
        recursively.
"
  (MAP-DOMAIN-TREE
   (if dump-records
       (LAMBDA (DOMAIN FQDN)
         (DECLARE (IGNORE DOMAIN))
         (print-domain-records fqdn :output OUTPUT :type type))
       (LAMBDA (DOMAIN FQDN)
         (DECLARE (IGNORE DOMAIN))
         (FORMAT OUTPUT "~50@A~%" FQDN)))
   DOMAIN)
  (VALUES))

;;;------------------------------------------------------------------------
;;;; dns.lisp                         --                     --          ;;;;