;;; -*-lisp-*-
;;;
;;; $Id$
;;;
;;; DNS zone generation
;;;
;;; (c) 2005 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; 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.

(defpackage #:zone
  (:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #:mdw.safely)
  (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp
	   #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet
	     #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet
	     #:ipnet-pretty #:ipnet-string #:ipnet-broadcast #:ipnet-hosts
	     #:ipnet-host #:ipaddr-networkp #:ipnet-subnetp
	   #:host-find# #:host-create #:defhost #:parse-ipaddr
	     #:net #:net-find #:net-get-as-ipnet #:net-create #:defnet
	     #:net-next-host #:net-host
	   #:soa #:mx #:zone #:zone-record #:zone-subdomain
	   #:*default-zone-source* #:*default-zone-refresh*
	     #:*default-zone-retry* #:*default-zone-expire*
	     #:*default-zone-min-ttl* #:*default-zone-ttl*
	     #:*default-mx-priority* #:*default-zone-admin*
	     #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
	     #:defrevzone #:zone-save
	   #:defzoneparse #:zone-parse-host
	   #:timespec-seconds #:make-zone-serial))
(in-package #:zone)

(defun mask (n)
  "Return 2^N - 1: i.e., a mask of N set bits."
  (1- (ash 1 n)))
(deftype u32 ()
  "The type of unsigned 32-bit values."
  '(unsigned-byte 32))
(deftype ipaddr ()
  "The type of IP (version 4) addresses."
  'u32)

(defun string-ipaddr (str &key (start 0) (end nil))
  "Parse STR as an IP address in dotted-quad form and return the integer
equivalent.  STR may be anything at all: it's converted as if by
`stringify'.  The START and END arguments may be used to parse out a
substring."
  (setf str (stringify str))
  (unless end
    (setf end (length str)))
  (let ((addr 0) (noct 0))
    (loop
      (let* ((pos (position #\. str :start start :end end))
	     (i (parse-integer str :start start :end (or pos end))))
	(unless (<= 0 i 256)
	  (error "IP address octet out of range"))
	(setf addr (+ (* addr 256) i))
	(incf noct)
	(unless pos
	  (return))
	(setf start (1+ pos))))
    (unless (= noct 4)
      (error "Wrong number of octets in IP address"))
    addr))
(defun ipaddr-byte (ip n)
  "Return byte N (from most significant downwards) of an IP address."
  (assert (<= 0 n 3))
  (logand #xff (ash ip (* -8 (- 3 n)))))
(defun ipaddr-string (ip)
  "Transform the address IP into a string in dotted-quad form."
  (check-type ip ipaddr)
  (join-strings #\. (collecting ()
		      (dotimes (i 4)
			(collect (ipaddr-byte ip i))))))
(defun ipaddrp (ip)
  "Answer true if IP is a valid IP address in integer form."
  (typep ip 'ipaddr))
(defun ipaddr (ip)
  "Convert IP to an IP address.  If it's an integer, return it unchanged;
otherwise convert by `string-ipaddr'."
  (typecase ip
    (ipaddr ip)
    (t (string-ipaddr ip))))

(defun integer-netmask (i)
  "Given an integer I, return a netmask with its I top bits set."
  (- (ash 1 32) (ash 1 (- 32 i))))
(defun ipmask (ip)
  "Transform IP into a netmask.  If it's a small integer then it's converted
by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
`ipaddr'."
  (typecase ip
    (null (mask 32))
    ((integer 0 32) (integer-netmask ip))
    (t (ipaddr ip))))
(defun ipmask-cidl-slash (mask)
  "Given a netmask MASK, return an integer N such that (integer-netmask N) =
MASK, or nil if this is impossible."
  (dotimes (i 33)
    (when (= mask (integer-netmask i))
      (return i))))

(defun make-ipnet (net mask)
  "Construct an IP-network object given the NET and MASK; these are
transformed as though by `ipaddr' and `ipmask'."
  (let ((net (ipaddr net))
	(mask (ipmask mask)))
    (cons (logand net mask) mask)))
(defun string-ipnet (str &key (start 0) (end nil))
  "Parse an IP-network from the string STR."
  (setf str (stringify str))
  (unless end (setf end (length str)))
  (let ((sl (position #\/ str :start start :end end)))
    (if sl
	(make-ipnet (parse-ipaddr (subseq str start sl))
		    (if (find #\. str :start (1+ sl) :end end)
			(string-ipaddr str :start (1+ sl) :end end)
			(integer-netmask (parse-integer str
							:start (1+ sl)
							:end end))))
	(make-ipnet (parse-ipaddr (subseq str start end))
		    (integer-netmask 32)))))
(defun ipnet (net &optional mask)
  "Construct an IP-network object from the given arguments.  A number of
forms are acceptable:

  * NET MASK -- as for `make-ipnet'.
  * ADDR -- a single address (equivalent to ADDR 32)
  * (NET . MASK|nil) -- a single-object representation.
  * IPNET -- return an equivalent (`equal', not necessarily `eql') version."
  (cond (mask (make-ipnet net mask))
	((or (stringp net) (symbolp net)) (string-ipnet net))
	(t (apply #'make-ipnet (pairify net 32)))))
(defun ipnet-net (ipn)
  "Return the base network address of IPN."
  (car ipn))
(defun ipnet-mask (ipn)
  "Return the netmask of IPN."
  (cdr ipn))
(defmacro with-ipnet ((net mask) ipn &body body)
  "Evaluate BODY with NET and MASK bound to the base address and netmask of
IPN.  Either NET or MASK (or, less usefully, both) may be nil if not wanted."
  (with-gensyms tmp
    `(let ((,tmp ,ipn))
       (let (,@(and net `((,net (ipnet-net ,tmp))))
	     ,@(and mask `((,mask (ipnet-mask ,tmp)))))
	 ,@body))))
(defun ipnet-pretty (ipn)
  "Convert IPN to a pretty cons-cell form."
  (with-ipnet (net mask) ipn
    (cons (ipaddr-string net)
	  (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
(defun ipnet-string (ipn)
  "Convert IPN to a string."
  (with-ipnet (net mask) ipn
    (format nil "~A/~A"
	    (ipaddr-string net)
	    (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
(defun ipnet-broadcast (ipn)
  "Return the broadcast address for the network IPN."
  (with-ipnet (net mask) ipn
    (logior net (logxor (mask 32) mask))))
(defun ipnet-hosts (ipn)
  "Return the number of available addresses in network IPN."
  (ash 1 (- 32 (logcount (ipnet-mask ipn)))))
(defun ipnet-host (ipn host)
  "Return the address of the given HOST in network IPN.  This works even with
a non-contiguous netmask."
  (check-type host u32)
  (with-ipnet (net mask) ipn
    (let ((i 0) (m 1) (a net) (h host))
      (loop
        (when (>= i 32)
	  (error "Host index ~D out of range for network ~A"
		 host (ipnet-pretty ipn)))
        (cond ((zerop h)
	       (return a))
	      ((logbitp i mask)
	       (setf h (ash h 1)))
	      (t
	       (setf a (logior a (logand m h)))
	       (setf h (logandc2 h m))))
	(setf m (ash m 1))
	(incf i)))))
(defun ipaddr-networkp (ip ipn)
  "Returns true if address IP is within network IPN."
  (with-ipnet (net mask) ipn
    (= net (logand ip mask))))
(defun ipnet-subnetp (ipn subn)
  "Returns true if SUBN is a (non-strict) subnet of IPN."
  (with-ipnet (net mask) ipn
    (with-ipnet (subnet submask) subn
      (and (= net (logand subnet mask))
	   (= submask (logior mask submask))))))

(defun resolve-hostname (name)
  "Resolve a hostname to an IP address using the DNS, or return nil."
  (let ((he (ext:lookup-host-entry name)))
    (and he
	 (ext:host-entry-addr he))))
(defun canonify-hostname (name)
  "Resolve a hostname to canonical form using the DNS, or return nil."
  (let ((he (ext:lookup-host-entry name)))
    (and he
	 (ext:host-entry-name he))))
(defun parse-ipaddr (addr)
  "Convert the string ADDR into an IP address: tries all sorts of things:

  (NET [INDEX]) -- index a network: NET is a network name defined by defnet;
    INDEX is an index or one of the special symbols understood by net-host,
    and defaults to :next
  INTEGER -- an integer IP address
  IPADDR -- an IP address in dotted-quad form
  HOST -- a host name defined by defhost
  DNSNAME -- a name string to look up in the DNS"
  (cond ((listp addr)
	 (destructuring-bind
	     (net host)
	     (pairify addr :next)
	   (net-host (or (net-find net)
			 (error "Network ~A not found" net))
		     host)))
	((ipaddrp addr) addr)
	(t
	 (setf addr (string-downcase (stringify addr)))
	 (or (host-find addr)
	     (and (plusp (length addr))
		  (digit-char-p (char addr 0))
		  (string-ipaddr addr))
	     (resolve-hostname (stringify addr))
	     (error "Host name ~A unresolvable" addr)))))

(defvar *hosts* (make-hash-table :test #'equal)
  "The table of known hostnames.")
(defun host-find (name)
  "Find a host by NAME."
  (gethash (string-downcase (stringify name)) *hosts*))
(defun (setf host-find) (addr name)
  "Make NAME map to ADDR (must be an ipaddr in integer form)."
  (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
(defun host-create (name addr)
  "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
  (setf (host-find name) (parse-ipaddr addr)))
(defmacro defhost (name addr)
  "Main host definition macro.  Neither NAME nor ADDR is evaluated."
  `(progn
     (host-create ',name ',addr)
     ',name))

(defstruct (net (:predicate netp))
  "A network structure.  Slots:

NAME       The network's name, as a string
IPNET      The network base address and mask
HOSTS      Number of hosts in the network
NEXT       Index of the next unassigned host"
  name
  ipnet
  hosts
  next)

(defvar *networks* (make-hash-table :test #'equal)
  "The table of known networks.")
(defun net-find (name)
  "Find a network by NAME."
  (gethash (string-downcase (stringify name)) *networks*))
(defun (setf net-find) (net name)
  "Make NAME map to NET."
  (setf (gethash (string-downcase (stringify name)) *networks*) net))
(defun net-get-as-ipnet (form)
  "Transform FORM into an ipnet.  FORM may be a network name, or something
acceptable to the ipnet function."
  (let ((net (net-find form)))
    (if net (net-ipnet net)
	(ipnet form))))
(defun net-create (name &rest args)
  "Construct a new network called NAME and add it to the map.  The ARGS
describe the new network, in a form acceptable to the ipnet function."
  (let ((ipn (apply #'ipnet args)))
    (setf (net-find name)
	  (make-net :name (string-downcase (stringify name))
		    :ipnet ipn
		    :hosts (ipnet-hosts ipn)
		    :next 1))))
(defmacro defnet (name &rest args)
  "Main network definition macro.  Neither NAME nor any of the ARGS is
evaluated."
  `(progn
     (net-create ',name ,@(mapcar (lambda (x) `',x) args))
     ',name))
(defun net-next-host (net)
  "Given a NET, return the IP address (as integer) of the next available
address in the network."
  (unless (< (net-next net) (net-hosts net))
    (error "No more hosts left in network ~A" (net-name net)))
  (let ((next (net-next net)))
    (incf (net-next net))
    (net-host net next)))
(defun net-host (net host)
  "Return the given HOST on the NEXT.  HOST may be an index (in range, of
course), or one of the keywords:
:NEXT       next host, as by net-next-host
:NET        network base address
:BROADCAST  network broadcast address"
  (case host
    (:next (net-next-host net))
    (:net (ipnet-net (net-ipnet net)))
    (:broadcast (ipnet-broadcast (net-ipnet net)))
    (t (ipnet-host (net-ipnet net) host))))

(defun to-integer (x)
  "Convert X to an integer in the most straightforward way."
  (floor (rational x)))
(defun timespec-seconds (ts)
  "Convert a timespec TS to seconds.  A timespec may be a real count of
seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious time
units."
  (cond ((null ts) 0)
	((realp ts) (floor ts))
	((atom ts)
	 (error "Unknown timespec format ~A" ts))
	((null (cdr ts))
	 (timespec-seconds (car ts)))
	(t (+ (to-integer (* (car ts)
			     (case (intern (string-upcase
					    (stringify (cadr ts)))
					   '#:zone)
			       ((s sec secs second seconds) 1)
			       ((m min mins minute minutes) 60)
			       ((h hr hrs hour hours) #.(* 60 60))
			       ((d dy dys day days) #.(* 24 60 60))
			       ((w wk wks week weeks) #.(* 7 24 60 60))
			       ((y yr yrs year years) #.(* 365 24 60 60))
			       (t (error "Unknown time unit ~A"
					 (cadr ts))))))
	      (timespec-seconds (cddr ts))))))

(defstruct (soa (:predicate soap))
  "Start-of-authority record information."
  source
  admin
  refresh
  retry
  expire
  min-ttl
  serial)
(defstruct (mx (:predicate mxp))
  "Mail-exchange record information."
  priority
  domain)
(defstruct (zone (:predicate zonep))
  "Zone information."
  soa
  default-ttl
  name
  records)

(defvar *default-zone-source*
  (let ((hn (unix:unix-gethostname)))
    (and hn (concatenate 'string (canonify-hostname hn) ".")))
  "The default zone source: the current host's name.")
(defvar *default-zone-refresh* (* 24 60 60)
  "Default zone refresh interval: one day.")
(defvar *default-zone-admin* nil
  "Default zone administrator's email address.")
(defvar *default-zone-retry* (* 60 60)
  "Default znoe retry interval: one hour.")
(defvar *default-zone-expire* (* 14 24 60 60)
  "Default zone expiry time: two weeks.")
(defvar *default-zone-min-ttl* (* 4 60 60)
  "Default zone minimum TTL/negative TTL: four hours.")
(defvar *default-zone-ttl* (* 8 60 60)
  "Default zone TTL (for records without explicit TTLs): 8 hours.")
(defvar *default-mx-priority* 50
  "Default MX priority.")

(defun from-mixed-base (base val)
  "BASE is a list of the ranges for the `digits' of a mixed-base
representation.  Convert VAL, a list of digits, into an integer."
  (do ((base base (cdr base))
       (val (cdr val) (cdr val))
       (a (car val) (+ (* a (car base)) (car val))))
      ((or (null base) (null val)) a)))
(defun to-mixed-base (base val)
  "BASE is a list of the ranges for the `digits' of a mixed-base
representation.  Convert VAL, an integer, into a list of digits."
  (let ((base (reverse base))
	(a nil))
    (loop
      (unless base
	(push val a)
	(return a))
      (multiple-value-bind (q r) (floor val (pop base))
	(push r a)
	(setf val q)))))

(defun make-zone-serial (name)
  "Given a zone NAME, come up with a new serial number.  This will (very
carefully) update a file ZONE.serial in the current directory."
  (let* ((file (format nil "~(~A~).serial" name))
	 (last (with-open-file (in file
				   :direction :input
				   :if-does-not-exist nil)
		 (if in (read in)
		     (list 0 0 0 0))))
	 (now (multiple-value-bind
		  (sec min hr dy mon yr dow dstp tz)
		  (get-decoded-time)
		(declare (ignore sec min hr dow dstp tz))
		(list dy mon yr)))
	 (seq (cond ((not (equal now (cdr last))) 0)
		    ((< (car last) 99) (1+ (car last)))
		    (t (error "Run out of sequence numbers for ~A" name)))))
    (safely-writing (out file)
      (format out
	      ";; Serial number file for zone ~A~%~
               ;;   (LAST-SEQ DAY MONTH YEAR)~%~
               ~S~%"
	      name
	      (cons seq now)))
    (from-mixed-base '(100 100 100) (reverse (cons seq now)))))

(defvar *zones* (make-hash-table :test #'equal)
  "Map of known zones.")
(defun zone-find (name)
  "Find a zone given its NAME."
  (gethash (string-downcase (stringify name)) *zones*))
(defun (setf zone-find) (zone name)
  "Make the zone NAME map to ZONE."
  (setf (gethash (string-downcase (stringify name)) *zones*) zone))

(defstruct (zone-record (:conc-name zr-))
  "A zone record."
  (name '<unnamed>)
  ttl
  type
  (defsubp nil)
  data)

(defstruct (zone-subdomain (:conc-name zs-))
  "A subdomain.  Slightly weird.  Used internally by zone-process-records
below, and shouldn't escape."
  name
  ttl
  records)

(defun zone-process-records (rec ttl func)
  "Sort out the list of records in REC, calling FUNC for each one.  TTL is
the default time-to-live for records which don't specify one."
  (labels ((sift (rec ttl)
	     (collecting (top sub)
	       (loop
		 (unless rec
		   (return))
		 (let ((r (pop rec)))
		   (cond ((eq r :ttl)
			  (setf ttl (pop rec)))
			 ((symbolp r)
			  (collect (make-zone-record :type r
						     :ttl ttl
						     :data (pop rec))
				   top))
			 ((listp r)
			  (dolist (name (listify (car r)))
			    (collect (make-zone-subdomain :name name
							  :ttl ttl
							  :records (cdr r))
				     sub)))
			 (t
			  (error "Unexpected record form ~A" (car r))))))))
	   (process (rec dom ttl defsubp)
	     (multiple-value-bind (top sub) (sift rec ttl)
	       (if (and dom (null top) sub)
		   (let ((s (pop sub)))
		     (process (zs-records s)
			      dom
			      (zs-ttl s)
			      defsubp)
		     (process (zs-records s)
			      (cons (zs-name s) dom)
			      (zs-ttl s)
			      t))
		 (let ((name (and dom
				  (string-downcase
				   (join-strings #\. (reverse dom))))))
		   (dolist (zr top)
		     (setf (zr-name zr) name)
		     (setf (zr-defsubp zr) defsubp)
		     (funcall func zr))))
	       (dolist (s sub)
		 (process (zs-records s)
			  (cons (zs-name s) dom)
			  (zs-ttl s)
			  defsubp)))))
    (process rec nil ttl nil)))

(defun zone-parse-host (f zname)
  "Parse a host name F: if F ends in a dot then it's considered absolute;
otherwise it's relative to ZNAME."
  (setf f (stringify f))
  (cond ((string= f "@") (stringify zname))
	((and (plusp (length f))
	      (char= (char f (1- (length f))) #\.))
	 (string-downcase (subseq f 0 (1- (length f)))))
	(t (string-downcase (concatenate 'string f "."
					 (stringify zname))))))
(defun ipnet-changeable-bytes (mask)
  "Answers how many low-order bytes of MASK are (entirely or partially)
changeable.  This is used when constructing reverse zones."
  (dotimes (i 4 4)
    (when (/= (ipaddr-byte mask i) 255)
      (return (- 4 i)))))
(defun default-rev-zone (base bytes)
  (join-strings #\. (collecting ()
		      (loop for i from (- 3 bytes) downto 0
			    do (collect (ipaddr-byte base i)))
		      (collect "in-addr.arpa"))))

(defun zone-name-from-net (net &optional bytes)
  "Given a NET, and maybe the BYTES to use, convert to the appropriate
subdomain of in-addr.arpa."
  (let ((ipn (net-get-as-ipnet net)))
    (with-ipnet (net mask) ipn
      (unless bytes
	(setf bytes (- 4 (ipnet-changeable-bytes mask))))
      (join-strings #\.
		    (append (loop
			       for i from (- 4 bytes) below 4
			       collect (logand #xff (ash net (* -8 i))))
			    (list "in-addr.arpa"))))))
		      
(defun zone-net-from-name (name)
  "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
  (let* ((name (string-downcase (stringify name)))
	 (len (length name))
	 (suffix ".in-addr.arpa")
	 (sufflen (length suffix))
	 (addr 0)
	 (n 0)
	 (end (- len sufflen)))
    (unless (and (> len sufflen)
		 (string= name suffix :start1 end))
      (error "`~A' not in ~A." name suffix))
    (loop
       with start = 0
       for dot = (position #\. name :start start :end end)
       for byte = (parse-integer name
				 :start start
				 :end (or dot end))
       do (setf addr (logior addr (ash byte (* 8 n))))
	  (incf n)
       when (>= n 4)
       do (error "Can't deduce network from ~A." name)
       while dot
       do (setf start (1+ dot)))
    (setf addr (ash addr (* 8 (- 4 n))))
    (make-ipnet addr (* 8 n))))

(defun zone-reverse-records (records net list bytes dom)
  "Construct a reverse zone given a forward zone's RECORDS list, the NET that
the reverse zone is to serve, a LIST to collect the records into, how
many BYTES of data need to end up in the zone, and the DOM-ain suffix."
  (dolist (zr records)
    (when (and (eq (zr-type zr) :a)
	       (not (zr-defsubp zr))
	       (ipaddr-networkp (zr-data zr) net))
      (collect (make-zone-record
		:name (string-downcase
		       (join-strings
			#\.
			(collecting ()
			  (dotimes (i bytes)
			    (collect (logand #xff (ash (zr-data zr)
						       (* -8 i)))))
			  (collect dom))))
		:type :ptr
		:ttl (zr-ttl zr)
		:data (zr-name zr))
	       list))))

(defun zone-reverse (data name list)
  "Process a :reverse record's DATA, for a domain called NAME, and add the
records to the LIST."
  (destructuring-bind
      (net &key bytes zones)
      (listify data)
    (setf net (zone-parse-net net name))
    (dolist (z (or (listify zones)
		   (hash-table-keys *zones*)))
      (zone-reverse-records (zone-records (zone-find z))
			    net
			    list
			    (or bytes
				(ipnet-changeable-bytes (ipnet-mask net)))
			    name))))

(defun zone-parse-net (net name)
  "Given a NET, and the NAME of a domain to guess from if NET is null,
return the ipnet for the network."
  (if net
      (net-get-as-ipnet net)
      (zone-net-from-name name)))

(defun zone-cidr-delg-default-name (ipn bytes)
  "Given a delegated net IPN and the parent's number of changing BYTES,
return the default deletate zone prefix."
  (with-ipnet (net mask) ipn
    (join-strings #\.
		  (reverse
		   (loop
		      for i from (1- bytes) downto 0
		      until (zerop (logand mask (ash #xff (* 8 i))))
		      collect (logand #xff (ash net (* -8 i))))))))

(defun zone-cidr-delegation (data name ttl list)
  "Given :cidr-delegation info DATA, for a record called NAME and the current
TTL, write lots of CNAME records to LIST."
  (destructuring-bind
      (net &key bytes)
      (listify (car data))
    (setf net (zone-parse-net net name))
    (unless bytes
      (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
    (dolist (map (cdr data))
      (destructuring-bind
	  (tnet &optional tdom)
	  (listify map)
	(setf tnet (zone-parse-net tnet name))
	(unless (ipnet-subnetp net tnet)
	  (error "~A is not a subnet of ~A."
		 (ipnet-pretty tnet)
		 (ipnet-pretty net)))		 
	(unless tdom
	  (setf tdom
		(join-strings #\.
			      (list (zone-cidr-delg-default-name tnet bytes)
				    name))))
	(setf tdom (string-downcase tdom))
	(dotimes (i (ipnet-hosts tnet))
	  (let* ((addr (ipnet-host tnet i))
		 (tail (join-strings #\.
				     (loop
					for i from 0 below bytes
					collect
					  (logand #xff
						  (ash addr (* 8 i)))))))
	    (collect (make-zone-record
		      :name (join-strings #\.
					  (list tail name))
		      :type :cname
		      :ttl ttl
		      :data (join-strings #\. (list tail tdom)))
		     list)))))))
						  
	      

(defun zone-parse-head (head)
  "Parse the HEAD of a zone form.  This has the form

     (NAME &key :source :admin :refresh :retry
                :expire :min-ttl :ttl :serial)

though a singleton NAME needn't be a list.  Returns the default TTL and an
soa structure representing the zone head."
  (destructuring-bind
      (zname
       &key
       (source *default-zone-source*)
       (admin (or *default-zone-admin*
		  (format nil "hostmaster@~A" zname)))
       (refresh *default-zone-refresh*)
       (retry *default-zone-retry*)
       (expire *default-zone-expire*)
       (min-ttl *default-zone-min-ttl*)
       (ttl min-ttl)
       (serial (make-zone-serial zname)))
      (listify head)
    (values zname
	    (timespec-seconds ttl)
	    (make-soa :admin admin
		      :source (zone-parse-host source zname)
		      :refresh (timespec-seconds refresh)
		      :retry (timespec-seconds retry)
		      :expire (timespec-seconds expire)
		      :min-ttl (timespec-seconds min-ttl)
		      :serial serial))))

(defun hash-table-keys (ht)
  "Return a list of the keys in hashtable HT."
  (collecting ()
    (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))

(defmacro defzoneparse (types (name data list
			       &key (zname (gensym "ZNAME"))
			            (ttl (gensym "TTL"))
				    (defsubp (gensym "DEFSUBP")))
			&body body)
  (setf types (listify types))
  (let* ((type (car types))
	 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
    (with-gensyms (col tname ttype tttl tdata tdefsubp i)
      `(progn
	 (dolist (,i ',types)
	   (setf (get ,i 'zone-parse) ',func))
	 (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
	   (declare (ignorable ,zname ,defsubp))
	   (flet ((,list (&key ((:name ,tname) ,name)
			       ((:type ,ttype) ,type)
			       ((:data ,tdata) ,data)
			       ((:ttl ,tttl) ,ttl)
			       ((:defsubp ,tdefsubp) nil))
		    (collect (make-zone-record :name ,tname
					       :type ,ttype
					       :data ,tdata
					       :ttl ,tttl
					       :defsubp ,tdefsubp)
			     ,col)))
	     ,@body))
	 ',type))))

(defun zone-parse-records (zone records)
  (let ((zname (zone-name zone)))
    (with-collection (rec)
	(flet ((parse-record (zr)
		 (let ((func (or (get (zr-type zr) 'zone-parse)
				 (error "No parser for record ~A."
					(zr-type zr))))
		       (name (and (zr-name zr)
				  (stringify (zr-name zr)))))
		   (if (or (not name)
			   (string= name "@"))
		       (setf name zname)
		       (let ((len (length name)))
			 (if (or (zerop len)
				 (char/= (char name (1- len)) #\.))
			     (setf name (join-strings #\.
						      (list name zname))))))
		   (funcall func
			    name
			    (zr-data zr)
			    (zr-ttl zr)
			    rec
			    zname
			    (zr-defsubp zr)))))
	  (zone-process-records records
				(zone-default-ttl zone)
				#'parse-record ))
      (setf (zone-records zone) (nconc (zone-records zone) rec)))))

(defun zone-parse (zf)
  "Parse a ZONE form.  The syntax of a zone form is as follows:

ZONE-FORM:
  ZONE-HEAD ZONE-RECORD*

ZONE-RECORD:
  ((NAME*) ZONE-RECORD*)
| SYM ARGS"
  (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
    (let ((zone (make-zone :name zname
			   :default-ttl ttl
			   :soa soa
			   :records nil)))
      (zone-parse-records zone (cdr zf))
      zone)))

(defzoneparse :a (name data rec :defsubp defsubp)
  ":a IPADDR"
  (rec :data (parse-ipaddr data) :defsubp defsubp))
(defzoneparse :ptr (name data rec :zname zname)
  ":ptr HOST"
  (rec :data (zone-parse-host data zname)))
(defzoneparse :cname (name data rec :zname zname)
  ":cname HOST"
  (rec :data (zone-parse-host data zname)))
(defzoneparse :mx (name data rec :zname zname)
  ":mx ((HOST :prio INT :ip IPADDR)*)"
  (dolist (mx (listify data))
    (destructuring-bind
	(mxname &key (prio *default-mx-priority*) ip)
	(listify mx)
      (let ((host (zone-parse-host mxname zname)))
	(when ip (rec :name host :type :a :data (parse-ipaddr ip)))
	(rec :data (cons host prio))))))
(defzoneparse :ns (name data rec :zname zname)
  ":ns ((HOST :ip IPADDR)*)"
  (dolist (ns (listify data))
    (destructuring-bind
	(nsname &key ip)
	(listify ns)
      (let ((host (zone-parse-host nsname zname)))
	(when ip (rec :name host :type :a :data (parse-ipaddr ip)))
	(rec :data host)))))
(defzoneparse :alias (name data rec :zname zname)
  ":alias (LABEL*)"
  (dolist (a (listify data))
    (rec :name (zone-parse-host a zname)
	 :type :cname
	 :data name)))
(defzoneparse :net (name data rec)
  ":net (NETWORK*)"
  (dolist (net (listify data))
    (let ((n (net-get-as-ipnet net)))
      (rec :name (zone-parse-host "net" name)
	   :type :a
	   :data (ipnet-net n))
      (rec :name (zone-parse-host "mask" name)
	   :type :a
	   :data (ipnet-mask n))
      (rec :name (zone-parse-host "broadcast" name)
	   :type :a
	   :data (ipnet-broadcast n)))))
  
(defzoneparse (:rev :reverse) (name data rec)
  ":reverse ((NET :bytes BYTES) ZONE*)"
  (setf data (listify data))
  (destructuring-bind
      (net &key bytes)
      (listify (car data))
    (setf net (zone-parse-net net name))
    (unless bytes
      (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
    (dolist (z (or (cdr data)
		   (hash-table-keys *zones*)))
      (dolist (zr (zone-records (zone-find z)))
	(when (and (eq (zr-type zr) :a)
		   (not (zr-defsubp zr))
		   (ipaddr-networkp (zr-data zr) net))
	  (rec :name (string-downcase
		      (join-strings
		       #\.
		       (collecting ()
			 (dotimes (i bytes)
			   (collect (logand #xff (ash (zr-data zr)
						      (* -8 i)))))
			 (collect name))))
	       :type :ptr
	       :ttl (zr-ttl zr)
	       :data (zr-name zr)))))))

(defzoneparse (:cidr-delegation :cidr) (name data rec)
  ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
  (destructuring-bind
      (net &key bytes)
      (listify (car data))
    (setf net (zone-parse-net net name))
    (unless bytes
      (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
    (dolist (map (cdr data))
      (destructuring-bind
	  (tnet &optional tdom)
	  (listify map)
	(setf tnet (zone-parse-net tnet name))
	(unless (ipnet-subnetp net tnet)
	  (error "~A is not a subnet of ~A."
		 (ipnet-pretty tnet)
		 (ipnet-pretty net)))		 
	(unless tdom
	  (with-ipnet (net mask) tnet
	    (setf tdom
		  (join-strings
		   #\.
		   (append (reverse (loop
				       for i from (1- bytes) downto 0
				       until (zerop (logand mask
							    (ash #xff
								 (* 8 i))))
				       collect (logand #xff
						       (ash net (* -8 i)))))
			   (list name))))))
	(setf tdom (string-downcase tdom))
	(dotimes (i (ipnet-hosts tnet))
	  (let* ((addr (ipnet-host tnet i))
		 (tail (join-strings #\.
				     (loop
					for i from 0 below bytes
					collect
					  (logand #xff
						  (ash addr (* 8 i)))))))
	    (rec :name (format nil "~A.~A" tail name)
		 :type :cname
		 :data (format nil "~A.~A" tail tdom))))))))

(defun iso-date (&optional time &key datep timep (sep #\ ))
  "Construct a textual date or time in ISO format.  The TIME is the universal
time to convert, which defaults to now; DATEP is whether to emit the date;
TIMEP is whether to emit the time, and SEP (default is space) is how to
separate the two."
  (multiple-value-bind
      (sec min hr day mon yr dow dstp tz)
      (decode-universal-time (if (or (null time) (eq time :now))
				 (get-universal-time)
				 time))
    (declare (ignore dow dstp tz))
    (with-output-to-string (s)
      (when datep
	(format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
	(when timep
	  (write-char sep s)))
      (when timep
	(format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))

(defun zone-write (zone &optional (stream *standard-output*))
  "Write a ZONE's records to STREAM."
  (labels ((fix-admin (a)
	     (let ((at (position #\@ a))
		   (s (concatenate 'string (string-downcase a) ".")))
	       (when s
		 (setf (char s at) #\.))
	       s))
	   (fix-host (h)
	     (if (not h)
		 "@"
		 (let* ((h (string-downcase (stringify h)))
			(hl (length h))
			(r (string-downcase (zone-name zone)))
			(rl (length r)))
		   (cond ((string= r h) "@")
			 ((and (> hl rl)
			       (char= (char h (- hl rl 1)) #\.)
			       (string= h r :start1 (- hl rl)))
			  (subseq h 0 (- hl rl 1)))
			 (t (concatenate 'string h "."))))))
	   (printrec (zr)
	     (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
		     (fix-host (zr-name zr))
		     (and (/= (zr-ttl zr) (zone-default-ttl zone))
			  (zr-ttl zr))
		     (string-upcase (symbol-name (zr-type zr))))))
    (format stream "~
;;; Zone file `~(~A~)'
;;;   (generated ~A)

$ORIGIN ~@0*~(~A.~)
$TTL ~@2*~D~2%"
	    (zone-name zone)
	    (iso-date :now :datep t :timep t)
	    (zone-default-ttl zone))
    (let ((soa (zone-soa zone)))
      (format stream "~
~A~30TIN SOA~40T~A ~A (
~45T~10D~60T ;serial
~45T~10D~60T ;refresh
~45T~10D~60T ;retry
~45T~10D~60T ;expire
~45T~10D )~60T ;min-ttl~2%"
	      (fix-host (zone-name zone))
	      (fix-host (soa-source soa))
	      (fix-admin (soa-admin soa))
	      (soa-serial soa)
	      (soa-refresh soa)
	      (soa-retry soa)
	      (soa-expire soa)
	      (soa-min-ttl soa)))
    (dolist (zr (zone-records zone))
      (case (zr-type zr)
	(:a
	 (printrec zr)
	 (format stream "~A~%" (ipaddr-string (zr-data zr))))
	((:ptr :cname)
	 (printrec zr)
	 (format stream "~A~%" (fix-host (zr-data zr))))
	(:ns
	 (printrec zr)
	 (format stream "~A~%" (fix-host (zr-data zr))))
	(:mx
	 (printrec zr)
	 (let ((mx (zr-data zr)))
	   (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
	(:txt
	 (printrec zr)
	 (format stream "~S~%" (stringify (zr-data zr))))))))

(defun zone-create (zf)
  "Zone construction function.  Given a zone form ZF, construct the zone and
add it to the table."
  (let* ((zone (zone-parse zf))
	 (name (zone-name zone)))
    (setf (zone-find name) zone)
    name))
(defmacro defzone (soa &rest zf)
  "Zone definition macro."
  `(zone-create '(,soa ,@zf)))
(defmacro defrevzone (head &rest zf)
  "Define a reverse zone, with the correct name."
  (destructuring-bind
      (net &rest soa-args)
      (listify head)
    (let ((bytes nil))
      (when (and soa-args (integerp (car soa-args)))
	(setf bytes (pop soa-args)))
      `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
		       

(defun zone-save (zones)
  "Write the named ZONES to files.  If no zones are given, write all the
zones."
  (unless zones
    (setf zones (hash-table-keys *zones*)))
  (safely (safe)
    (dolist (z zones)
      (let ((zz (zone-find z)))
	(unless zz
	  (error "Unknown zone `~A'." z))
	(let ((stream (safely-open-output-stream safe
						 (string-downcase
						  (stringify z)))))
	  (zone-write zz stream))))))

;;;----- That's all, folks --------------------------------------------------