[zone] / zone.lisp

;;; -*-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.

;;;--------------------------------------------------------------------------
;;; Packaging.

(defpackage #:zone
  (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net)
  (:export #: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)

;;;--------------------------------------------------------------------------
;;; Various random utilities.

(defun to-integer (x)
  "Convert X to an integer in the most straightforward way."
  (floor (rational x)))

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

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

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

;;;--------------------------------------------------------------------------
;;; Zone types.

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

;;;--------------------------------------------------------------------------
;;; Zone defaults.  It is intended that scripts override these.

#+ecl
(cffi:defcfun gethostname :int
  (name :pointer)
  (len :uint))

(defvar *default-zone-source*
  (let ((hn #+cmu (unix:unix-gethostname)
	    #+clisp (unix:get-host-name)
	    #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
		    (let ((rc (gethostname buffer len)))
		      (unless (zerop rc)
			(error "gethostname(2) failed (rc = ~A)." rc))))))
    (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.")

;;;--------------------------------------------------------------------------
;;; Serial numbering.

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

;;;--------------------------------------------------------------------------
;;; Zone variables and structures.

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

;;;--------------------------------------------------------------------------
;;; Zone infrastructure.

(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 default-rev-zone (base bytes)
  "Return the default reverse-zone name for the given BASE address and number
   of fixed leading 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)))))))

;;;--------------------------------------------------------------------------
;;; Zone form parsing.

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

(defmacro defzoneparse (types (name data list
			       &key (zname (gensym "ZNAME"))
			            (ttl (gensym "TTL"))
				    (defsubp (gensym "DEFSUBP")))
			&body body)
  "Define a new zone record type (or TYPES -- a list of synonyms is
   permitted).  The arguments are as follows:

   NAME		The name of the record to be added.

   DATA		The content of the record to be added (a single object,
		unevaluated).

   LIST		A function to add a record to the zone.  See below.

   ZNAME	The name of the zone being constructed.

   TTL		The TTL for this record.

   DEFSUBP	Whether this is the default subdomain for this entry.

   You get to choose your own names for these.  ZNAME, TTL and DEFSUBP are
   optional: you don't have to accept them if you're not interested.

   The LIST argument names a function to be bound in the body to add a new
   low-level record to the zone.  It has the prototype

     (LIST &key :name :type :data :ttl :defsubp)

   Except for defsubp, these default to the above arguments (even if you
   didn't accept the arguments)."
  (setf types (listify types))
  (let* ((type (car types))
	 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
    (with-parsed-body (body decls doc) body
      (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)
	     ,@doc
	     ,@decls
	     (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)))

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

;;;--------------------------------------------------------------------------
;;; Zone record parsers.

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

;;;--------------------------------------------------------------------------
;;; Zone file output.

(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-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
						 (format nil
							 "~(~A~).zone"
							 z))))
	  (zone-write zz stream))))))

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