zone.lisp: Stringify the zone name at construction time.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index adcfb7e0ff04881867efd96e1f3a4bf27dfd0acd..6b84dac957619fea85e63928434e7b0049029bd1 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; DNS zone generation
 ;;;
 ;;; (c) 2005 Straylight/Edgeware
 ;;; DNS zone generation
 ;;;
 ;;; (c) 2005 Straylight/Edgeware


@@ -13,12 +11,12 @@
 ;;; 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.
 ;;; 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.
 ;;; 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.
 ;;; 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.


@@ -27,16 +25,10 @@
 ;;; Packaging.
 
 (defpackage #:zone
 ;;; 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))
+  (:use #:common-lisp
+       #:mdw.base #:mdw.str #:collect #:safely
+       #:net #:services)
+  (:import-from #:net #:round-down #:round-up))

 
 (in-package #:zone)
 
 
 (in-package #:zone)
 


@@ -68,10 +60,12 @@ (defun to-mixed-base (base val)
        (push r a)
        (setf val q)))))
 
        (push r a)
        (setf val q)))))
 

+(export 'timespec-seconds)

 (defun timespec-seconds (ts)
 (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."
+  "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)
   (cond ((null ts) 0)
        ((realp ts) (floor ts))
        ((atom ts)


@@ -98,10 +92,11 @@ (defun hash-table-keys (ht)
     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
 
 (defun iso-date (&optional time &key datep timep (sep #\ ))
     (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."
+  "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))
   (multiple-value-bind
       (sec min hr day mon yr dow dstp tz)
       (decode-universal-time (if (or (null time) (eq time :now))


@@ -119,6 +114,7 @@ (defun iso-date (&optional time &key datep timep (sep #\ ))
 ;;;--------------------------------------------------------------------------
 ;;; Zone types.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone types.
 

+(export 'soa)

 (defstruct (soa (:predicate soap))
   "Start-of-authority record information."
   source
 (defstruct (soa (:predicate soap))
   "Start-of-authority record information."
   source


@@ -129,11 +125,13 @@ (defstruct (soa (:predicate soap))
   min-ttl
   serial)
 
   min-ttl
   serial)
 

+(export 'mx)

 (defstruct (mx (:predicate mxp))
   "Mail-exchange record information."
   priority
   domain)
 
 (defstruct (mx (:predicate mxp))
   "Mail-exchange record information."
   priority
   domain)
 

+(export 'zone)

 (defstruct (zone (:predicate zonep))
   "Zone information."
   soa
 (defstruct (zone (:predicate zonep))
   "Zone information."
   soa


@@ -144,49 +142,160 @@ (defstruct (zone (:predicate zonep))
 ;;;--------------------------------------------------------------------------
 ;;; Zone defaults.  It is intended that scripts override these.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone defaults.  It is intended that scripts override these.
 

-#+ecl
-(cffi:defcfun gethostname :int
-  (name :pointer)
-  (len :uint))
-
+(export '*default-zone-source*)

 (defvar *default-zone-source*
 (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))))))
+  (let ((hn (gethostname)))

     (and hn (concatenate 'string (canonify-hostname hn) ".")))
   "The default zone source: the current host's name.")
 
     (and hn (concatenate 'string (canonify-hostname hn) ".")))
   "The default zone source: the current host's name.")
 

+(export '*default-zone-refresh*)

 (defvar *default-zone-refresh* (* 24 60 60)
   "Default zone refresh interval: one day.")
 
 (defvar *default-zone-refresh* (* 24 60 60)
   "Default zone refresh interval: one day.")
 

+(export '*default-zone-admin*)

 (defvar *default-zone-admin* nil
   "Default zone administrator's email address.")
 
 (defvar *default-zone-admin* nil
   "Default zone administrator's email address.")
 

+(export '*default-zone-retry*)

 (defvar *default-zone-retry* (* 60 60)
   "Default znoe retry interval: one hour.")
 
 (defvar *default-zone-retry* (* 60 60)
   "Default znoe retry interval: one hour.")
 

+(export '*default-zone-expire*)

 (defvar *default-zone-expire* (* 14 24 60 60)
   "Default zone expiry time: two weeks.")
 
 (defvar *default-zone-expire* (* 14 24 60 60)
   "Default zone expiry time: two weeks.")
 

+(export '*default-zone-min-ttl*)

 (defvar *default-zone-min-ttl* (* 4 60 60)
   "Default zone minimum TTL/negative TTL: four hours.")
 
 (defvar *default-zone-min-ttl* (* 4 60 60)
   "Default zone minimum TTL/negative TTL: four hours.")
 

+(export '*default-zone-ttl*)

 (defvar *default-zone-ttl* (* 8 60 60)
   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 
 (defvar *default-zone-ttl* (* 8 60 60)
   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 

+(export '*default-mx-priority*)

 (defvar *default-mx-priority* 50
   "Default MX priority.")
 
 (defvar *default-mx-priority* 50
   "Default MX priority.")
 

+;;;--------------------------------------------------------------------------
+;;; Zone variables and structures.
+
+(defvar *zones* (make-hash-table :test #'equal)
+  "Map of known zones.")
+
+(export 'zone-find)
+(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))
+
+(export 'zone-record)
+(defstruct (zone-record (:conc-name zr-))
+  "A zone record."
+  (name '<unnamed>)
+  ttl
+  type
+  (make-ptr-p nil)
+  data)
+
+(export 'zone-subdomain)
+(defstruct (zone-subdomain (:conc-name zs-))
+  "A subdomain.
+
+   Slightly weird.  Used internally by `zone-process-records', and shouldn't
+   escape."
+  name
+  ttl
+  records)
+
+(export '*zone-output-path*)
+(defvar *zone-output-path* nil
+  "Pathname defaults to merge into output files.
+
+   If this is nil then use the prevailing `*default-pathname-defaults*'.
+   This is not the same as capturing the `*default-pathname-defaults*' from
+   load time.")
+
+(export '*preferred-subnets*)
+(defvar *preferred-subnets* nil
+  "Subnets to prefer when selecting defaults.")
+
+;;;--------------------------------------------------------------------------
+;;; Zone infrastructure.
+
+(defun zone-file-name (zone type)
+  "Choose a file name for a given ZONE and TYPE."
+  (merge-pathnames (make-pathname :name (string-downcase zone)
+                                 :type (string-downcase type))
+                  (or *zone-output-path* *default-pathname-defaults*)))
+
+(export 'zone-preferred-subnet-p)
+(defun zone-preferred-subnet-p (name)
+  "Answer whether NAME (a string or symbol) names a preferred subnet."
+  (member name *preferred-subnets* :test #'string-equal))
+
+(export 'preferred-subnet-case)
+(defmacro preferred-subnet-case (&body clauses)
+  "Execute a form based on which networks are considered preferred.
+
+   The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
+   whose SUBNETS (a list or single symbol, not evaluated) are listed in
+   `*preferred-subnets*'.  If SUBNETS is the symbol `t' then the clause
+   always matches."
+  `(cond
+    ,@(mapcar (lambda (clause)
+               (let ((subnets (car clause)))
+                 (cons (cond ((eq subnets t)
+                              t)
+                             ((listp subnets)
+                              `(or ,@(mapcar (lambda (subnet)
+                                               `(zone-preferred-subnet-p
+                                                 ',subnet))
+                                             subnets)))
+                             (t
+                              `(zone-preferred-subnet-p ',subnets)))
+                       (cdr clause))))
+             clauses)))
+
+(export 'zone-parse-host)
+(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))))))
+
+(export 'zone-make-name)
+(defun zone-make-name (prefix zone-name)
+  "Compute a full domain name from a PREFIX and a ZONE-NAME.
+
+   If the PREFIX ends with `.' then it's absolute already; otherwise, append
+   the ZONE-NAME, separated with a `.'.  If PREFIX is nil, or `@', then
+   return the ZONE-NAME only."
+  (if (or (not prefix) (string= prefix "@"))
+      zone-name
+      (let ((len (length prefix)))
+       (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
+           (join-strings #\. (list prefix zone-name))
+           prefix))))
+

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

+(export 'make-zone-serial)

 (defun make-zone-serial (name)
 (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))
+  "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 (zone-file-name name :serial))

         (last (with-open-file (in file
                                   :direction :input
                                   :if-does-not-exist nil)
         (last (with-open-file (in file
                                   :direction :input
                                   :if-does-not-exist nil)


@@ -203,48 +312,57 @@ (defun make-zone-serial (name)
     (safely-writing (out file)
       (format out
              ";; Serial number file for zone ~A~%~
     (safely-writing (out file)
       (format out
              ";; Serial number file for zone ~A~%~

-               ;;   (LAST-SEQ DAY MONTH YEAR)~%~
-               ~S~%"
+              ;;   (LAST-SEQ DAY MONTH YEAR)~%~
+              ~S~%"

              name
              (cons seq now)))
     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 
 ;;;--------------------------------------------------------------------------
              name
              (cons seq now)))
     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 
 ;;;--------------------------------------------------------------------------

-;;; Zone variables and structures.
+;;; Zone form parsing.

 
 

-(defvar *zones* (make-hash-table :test #'equal)
-  "Map of known zones.")
+(defun zone-process-records (rec ttl func)
+  "Sort out the list of records in REC, calling FUNC for each one.

 
 

-(defun zone-find (name)
-  "Find a zone given its NAME."
-  (gethash (string-downcase (stringify name)) *zones*))
+   TTL is the default time-to-live for records which don't specify one.

 
 

-(defun (setf zone-find) (zone name)
-  "Make the zone NAME map to ZONE."
-  (setf (gethash (string-downcase (stringify name)) *zones*) zone))
+   REC is a list of records of the form

 
 

-(defstruct (zone-record (:conc-name zr-))
-  "A zone record."
-  (name '<unnamed>)
-  ttl
-  type
-  (defsubp nil)
-  data)
+       ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)

 
 

-(defstruct (zone-subdomain (:conc-name zs-))
-  "A subdomain.  Slightly weird.  Used internally by zone-process-records
-   below, and shouldn't escape."
-  name
-  ttl
-  records)
+   The various kinds of entries have the following meanings.

 
 

-;;;--------------------------------------------------------------------------
-;;; Zone infrastructure.
+   :ttl TTL            Set the TTL for subsequent records (at this level of
+                         nesting only).
+
+   TYPE DATA           Define a record with a particular TYPE and DATA.
+                         Record types are defined using `defzoneparse' and
+                         the syntax of the data is idiosyncratic.
+
+   ((LABEL ...) . REC) Define records for labels within the zone.  Any
+                         records defined within REC will have their domains
+                         prefixed by each of the LABELs.  A singleton list
+                         of labels may instead be written as a single
+                         label.  Note, therefore, that
+
+                               (host (sub :a \"169.254.1.1\"))
+
+                         defines a record for `host.sub' -- not `sub.host'.
+
+   If REC contains no top-level records, but it does define records for a
+   label listed in `*preferred-subnets*', then the records for the first such
+   label are also promoted to top-level.
+
+   The FUNC is called for each record encountered, represented as a
+   `zone-record' object.  Zone parsers are not called: you get the record
+   types and data from the input form; see `zone-parse-records' if you want
+   the raw output."

 
 

-(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)
   (labels ((sift (rec ttl)

+            ;; Parse the record list REC into lists of `zone-record' and
+            ;; `zone-subdomain' objects, sorting out TTLs and so on.
+            ;; Returns them as two values.
+

             (collecting (top sub)
               (loop
                 (unless rec
             (collecting (top sub)
               (loop
                 (unless rec


@@ -265,194 +383,46 @@ (defun zone-process-records (rec ttl func)
                                     sub)))
                         (t
                          (error "Unexpected record form ~A" (car r))))))))
                                     sub)))
                         (t
                          (error "Unexpected record form ~A" (car r))))))))

-          (process (rec dom ttl defsubp)
+
+          (process (rec dom ttl)
+            ;; Recursirvely process the record list REC, with a list DOM of
+            ;; prefix labels, and a default TTL.  Promote records for a
+            ;; preferred subnet to toplevel if there are no toplevel records
+            ;; already.
+

             (multiple-value-bind (top sub) (sift rec ttl)
               (if (and dom (null top) sub)
             (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))))
+                  (let ((preferred
+                         (or (find-if (lambda (s)
+                                        (some #'zone-preferred-subnet-p
+                                              (listify (zs-name s))))
+                                      sub)
+                             (car sub))))
+                    (when preferred
+                      (process (zs-records preferred)
+                               dom
+                               (zs-ttl preferred))))
+                  (let ((name (and dom
+                                   (string-downcase
+                                    (join-strings #\. (reverse dom))))))
+                    (dolist (zr top)
+                      (setf (zr-name zr) name)
+                      (funcall func zr))))

               (dolist (s sub)
                 (process (zs-records s)
                          (cons (zs-name s) dom)
               (dolist (s sub)
                 (process (zs-records s)
                          (cons (zs-name s) dom)

-                         (zs-ttl s)
-                         defsubp)))))
-    (process rec nil ttl nil)))
+                         (zs-ttl s))))))

 
 

-(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.
+    ;; Process the records we're given with no prefix.
+    (process rec nil ttl)))

 
 (defun zone-parse-head (head)
 
 (defun zone-parse-head (head)

-  "Parse the HEAD of a zone form.  This has the form
+  "Parse the HEAD of a zone form.
+
+   This has the form

 
      (NAME &key :source :admin :refresh :retry
 
      (NAME &key :source :admin :refresh :retry

-                :expire :min-ttl :ttl :serial)
+               :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."
 
    though a singleton NAME needn't be a list.  Returns the default TTL and an
    soa structure representing the zone head."


@@ -469,7 +439,7 @@ (defun zone-parse-head (head)
        (ttl min-ttl)
        (serial (make-zone-serial zname)))
       (listify head)
        (ttl min-ttl)
        (serial (make-zone-serial zname)))
       (listify head)

-    (values zname
+    (values (string-downcase zname)

            (timespec-seconds ttl)
            (make-soa :admin admin
                      :source (zone-parse-host source zname)
            (timespec-seconds ttl)
            (make-soa :admin admin
                      :source (zone-parse-host source zname)


@@ -479,94 +449,88 @@ (defun zone-parse-head (head)
                      :min-ttl (timespec-seconds min-ttl)
                      :serial serial))))
 
                      :min-ttl (timespec-seconds min-ttl)
                      :serial serial))))
 

+(export 'defzoneparse)

 (defmacro defzoneparse (types (name data list
 (defmacro defzoneparse (types (name data list

-                              &key (zname (gensym "ZNAME"))
-                                   (ttl (gensym "TTL"))
-                                   (defsubp (gensym "DEFSUBP")))
+                              &key (prefix (gensym "PREFIX"))
+                                   (zname (gensym "ZNAME"))
+                                   (ttl (gensym "TTL")))

                        &body body)
                        &body body)

-  "Define a new zone record type (or TYPES -- a list of synonyms is
-   permitted).  The arguments are as follows:
+  "Define a new zone record type.
+
+   The arguments are as follows:
+
+   TYPES       A singleton type symbol, or a list of aliases.

 
    NAME                The name of the record to be added.
 
    DATA                The content of the record to be added (a single object,
 
    NAME                The name of the record to be added.
 
    DATA                The content of the record to be added (a single object,

-               unevaluated). 
+               unevaluated).

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

+   PREFIX      The prefix tag used in the original form.
+

    ZNAME       The name of the zone being constructed.
 
    TTL         The TTL for this record.
 
    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
+   You get to choose your own names for these.  ZNAME, PREFIX and TTL 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
 
    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)
+     (LIST &key :name :type :data :ttl :make-ptr-p)

 
 

-   Except for defsubp, these default to the above arguments (even if you
-   didn't accept the arguments)."
+   These (except MAKE-PTR-P, which defaults to nil) 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))))
   (setf types (listify types))
   (let* ((type (car types))
         (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))

-    (with-parsed-body (doc decls body body)
-      (with-gensyms (col tname ttype tttl tdata tdefsubp i)
+    (with-parsed-body (body decls doc) body
+      (with-gensyms (col tname ttype tttl tdata tmakeptrp i)

        `(progn
           (dolist (,i ',types)
             (setf (get ,i 'zone-parse) ',func))
        `(progn
           (dolist (,i ',types)
             (setf (get ,i 'zone-parse) ',func))

-          (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
+          (defun ,func (,prefix ,zname ,data ,ttl ,col)

             ,@doc
             ,@decls
             ,@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))
+            (let ((,name (zone-make-name ,prefix ,zname)))
+              (flet ((,list (&key ((:name ,tname) ,name)
+                                  ((:type ,ttype) ,type)
+                                  ((:data ,tdata) ,data)
+                                  ((:ttl ,tttl) ,ttl)
+                                  ((:make-ptr-p ,tmakeptrp) nil))
+                       #+cmu (declare (optimize ext:inhibit-warnings))
+                       (collect (make-zone-record :name ,tname
+                                                  :type ,ttype
+                                                  :data ,tdata
+                                                  :ttl ,tttl
+                                                  :make-ptr-p ,tmakeptrp)
+                                ,col)))
+                ,@body)))

           ',type)))))
 
           ',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)))))
-
+(export 'zone-parse-records)
+(defun zone-parse-records (zname ttl records)
+  "Parse a sequence of RECORDS and return a list of raw records.
+
+   The records are parsed relative to the zone name ZNAME, and using the
+   given default TTL."
+  (collecting (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)))))
+              (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
+      (zone-process-records records ttl #'parse-record))))
+
+(export 'zone-parse)

 (defun zone-parse (zf)
 (defun zone-parse (zf)

-  "Parse a ZONE form.  The syntax of a zone form is as follows:
+  "Parse a ZONE form.
+
+   The syntax of a zone form is as follows:

 
    ZONE-FORM:
      ZONE-HEAD ZONE-RECORD*
 
    ZONE-FORM:
      ZONE-HEAD ZONE-RECORD*


@@ -575,13 +539,12 @@ (defun zone-parse (zf)
      ((NAME*) ZONE-RECORD*)
    | SYM ARGS"
   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
      ((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)))
+    (make-zone :name zname
+              :default-ttl ttl
+              :soa soa
+              :records (zone-parse-records zname ttl (cdr zf)))))

 
 

+(export 'zone-create)

 (defun zone-create (zf)
   "Zone construction function.  Given a zone form ZF, construct the zone and
    add it to the table."
 (defun zone-create (zf)
   "Zone construction function.  Given a zone form ZF, construct the zone and
    add it to the table."


@@ -590,26 +553,75 @@ (defun zone-create (zf)
     (setf (zone-find name) zone)
     name))
 
     (setf (zone-find name) zone)
     name))
 

-(defmacro defzone (soa &rest zf)
+(export 'defzone)
+(defmacro defzone (soa &body zf)

   "Zone definition macro."
   `(zone-create '(,soa ,@zf)))
 
   "Zone definition macro."
   `(zone-create '(,soa ,@zf)))
 

-(defmacro defrevzone (head &rest zf)
+(export '*address-family*)
+(defvar *address-family* t
+  "The default address family.  This is bound by `defrevzone'.")
+
+(export 'defrevzone)
+(defmacro defrevzone (head &body zf)

   "Define a reverse zone, with the correct name."
   "Define a reverse zone, with the correct name."

-  (destructuring-bind
-      (net &rest soa-args)
+  (destructuring-bind (nets &rest args
+                           &key &allow-other-keys
+                                (family '*address-family*)
+                                prefix-bits)

       (listify head)
       (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)))))
+    (with-gensyms (ipn)
+      `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
+        (let ((*address-family* (ipnet-family ,ipn)))
+          (zone-create `((,(reverse-domain ,ipn ,prefix-bits)
+                           ,@',(loop for (k v) on args by #'cddr
+                                     unless (member k
+                                                    '(:family :prefix-bits))
+                                     nconc (list k v)))
+                         ,@',zf)))))))
+
+(export 'map-host-addresses)
+(defun map-host-addresses (func addr &key (family *address-family*))
+  "Call FUNC for each address denoted by ADDR (a `host-parse' address)."
+
+  (dolist (a (host-addrs (host-parse addr family)))
+    (funcall func a)))
+
+(export 'do-host)
+(defmacro do-host ((addr spec &key (family *address-family*)) &body body)
+  "Evaluate BODY, binding ADDR to each address denoted by SPEC."
+  `(dolist (,addr (host-addrs (host-parse ,spec ,family)))
+     ,@body))
+
+(export 'zone-set-address)
+(defun zone-set-address (rec addrspec &rest args
+                        &key (family *address-family*) name ttl make-ptr-p)
+  "Write records (using REC) defining addresses for ADDRSPEC."
+  (declare (ignore name ttl make-ptr-p))
+  (let ((key-args (loop for (k v) on args by #'cddr
+                       unless (eq k :family)
+                       nconc (list k v))))
+    (do-host (addr addrspec :family family)
+      (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))

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

-(defzoneparse :a (name data rec :defsubp defsubp)
+(defzoneparse :a (name data rec)

   ":a IPADDR"
   ":a IPADDR"

-  (rec :data (parse-ipaddr data) :defsubp defsubp))
+  (zone-set-address #'rec data :make-ptr-p t :family :ipv4))
+
+(defzoneparse :aaaa (name data rec)
+  ":aaaa IPADDR"
+  (zone-set-address #'rec data :make-ptr-p t :family :ipv6))
+
+(defzoneparse :addr (name data rec)
+  ":addr IPADDR"
+  (zone-set-address #'rec data :make-ptr-p t))
+
+(defzoneparse :svc (name data rec)
+  ":svc IPADDR"
+  (zone-set-address #'rec data))

 
 (defzoneparse :ptr (name data rec :zname zname)
   ":ptr HOST"
 
 (defzoneparse :ptr (name data rec :zname zname)
   ":ptr HOST"


@@ -619,6 +631,102 @@ (defzoneparse :cname (name data rec :zname zname)
   ":cname HOST"
   (rec :data (zone-parse-host data zname)))
 
   ":cname HOST"
   (rec :data (zone-parse-host data zname)))
 

+(defzoneparse :txt (name data rec)
+  ":txt TEXT"
+  (rec :data data))
+
+(export '*dkim-pathname-defaults*)
+(defvar *dkim-pathname-defaults*
+  (make-pathname :directory '(:relative "keys")
+                :type "dkim"))
+
+(defzoneparse :dkim (name data rec)
+  ":dkim (KEYFILE {:TAG VALUE}*)"
+  (destructuring-bind (file &rest plist) (listify data)
+    (let ((things nil) (out nil))
+      (labels ((flush ()
+                (when out
+                  (push (get-output-stream-string out) things)
+                  (setf out nil)))
+              (emit (text)
+                (let ((len (length text)))
+                  (when (and out (> (+ (file-position out)
+                                       (length text))
+                                    64))
+                    (flush))
+                  (when (plusp len)
+                    (cond ((< len 64)
+                           (unless out (setf out (make-string-output-stream)))
+                           (write-string text out))
+                          (t
+                           (do ((i 0 j)
+                                (j 64 (+ j 64)))
+                               ((>= i len))
+                             (push (subseq text i (min j len)) things))))))))
+       (do ((p plist (cddr p)))
+           ((endp p))
+         (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
+       (emit (with-output-to-string (out)
+               (write-string "p=" out)
+               (when file
+                 (with-open-file
+                     (in (merge-pathnames file *dkim-pathname-defaults*))
+                   (loop
+                     (when (string= (read-line in)
+                                    "-----BEGIN PUBLIC KEY-----")
+                       (return)))
+                   (loop
+                     (let ((line (read-line in)))
+                       (if (string= line "-----END PUBLIC KEY-----")
+                           (return)
+                           (write-string line out)))))))))
+      (rec :type :txt
+          :data (nreverse things)))))
+
+(eval-when (:load-toplevel :execute)
+  (dolist (item '((sshfp-algorithm rsa 1)
+                 (sshfp-algorithm dsa 2)
+                 (sshfp-algorithm ecdsa 3)
+                 (sshfp-type sha-1 1)
+                 (sshfp-type sha-256 2)))
+    (destructuring-bind (prop sym val) item
+      (setf (get sym prop) val)
+      (export sym))))
+
+(export '*sshfp-pathname-defaults*)
+(defvar *sshfp-pathname-defaults*
+  (make-pathname :directory '(:relative "keys")
+                :type "sshfp"))
+
+(defzoneparse :sshfp (name data rec)
+  ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
+  (if (stringp data)
+      (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
+       (loop (let ((line (read-line in nil)))
+               (unless line (return))
+               (let ((words (str-split-words line)))
+                 (pop words)
+                 (when (string= (car words) "IN") (pop words))
+                 (unless (and (string= (car words) "SSHFP")
+                              (= (length words) 4))
+                   (error "Invalid SSHFP record."))
+                 (pop words)
+                 (destructuring-bind (alg type fpr) words
+                   (rec :data (list (parse-integer alg)
+                                    (parse-integer type)
+                                    fpr)))))))
+      (flet ((lookup (what prop)
+              (etypecase what
+                (fixnum what)
+                (symbol (or (get what prop)
+                            (error "~S is not a known ~A" what prop))))))
+       (dolist (item (listify data))
+         (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
+             (listify item)
+           (rec :data (list (lookup alg 'sshfp-algorithm)
+                            (lookup type 'sshfp-type)
+                            fpr)))))))
+

 (defzoneparse :mx (name data rec :zname zname)
   ":mx ((HOST :prio INT :ip IPADDR)*)"
   (dolist (mx (listify data))
 (defzoneparse :mx (name data rec :zname zname)
   ":mx ((HOST :prio INT :ip IPADDR)*)"
   (dolist (mx (listify data))


@@ -626,7 +734,7 @@ (defzoneparse :mx (name data rec :zname zname)
        (mxname &key (prio *default-mx-priority*) ip)
        (listify mx)
       (let ((host (zone-parse-host mxname zname)))
        (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)))
+       (when ip (zone-set-address #'rec ip :name host))

        (rec :data (cons host prio))))))
 
 (defzoneparse :ns (name data rec :zname zname)
        (rec :data (cons host prio))))))
 
 (defzoneparse :ns (name data rec :zname zname)


@@ -636,7 +744,7 @@ (defzoneparse :ns (name data rec :zname zname)
        (nsname &key ip)
        (listify ns)
       (let ((host (zone-parse-host nsname zname)))
        (nsname &key ip)
        (listify ns)
       (let ((host (zone-parse-host nsname zname)))

-       (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
+       (when ip (zone-set-address #'rec ip :name host))

        (rec :data host)))))
 
 (defzoneparse :alias (name data rec :zname zname)
        (rec :data host)))))
 
 (defzoneparse :alias (name data rec :zname zname)


@@ -646,121 +754,191 @@ (defzoneparse :alias (name data rec :zname zname)
         :type :cname
         :data name)))
 
         :type :cname
         :data name)))
 

+(defzoneparse :srv (name data rec :zname zname)
+  ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
+  (dolist (srv data)
+    (destructuring-bind (servopts &rest providers) srv
+      (destructuring-bind
+         (service &key ((:port default-port)) (protocol :tcp))
+         (listify servopts)
+       (unless default-port
+         (let ((serv (serv-by-name service protocol)))
+           (setf default-port (and serv (serv-port serv)))))
+       (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
+         (dolist (prov providers)
+           (destructuring-bind
+               (srvname
+                &key
+                (port default-port)
+                (prio *default-mx-priority*)
+                (weight 0)
+                ip)
+               (listify prov)
+             (let ((host (zone-parse-host srvname zname)))
+               (when ip (zone-set-address #'rec ip :name host))
+               (rec :name rname
+                    :data (list prio weight port host))))))))))
+

 (defzoneparse :net (name data rec)
   ":net (NETWORK*)"
   (dolist (net (listify data))
 (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)))))
-  
+    (dolist (ipn (net-ipnets (net-must-find net)))
+      (let* ((base (ipnet-net ipn))
+            (rrtype (ipaddr-rrtype base)))
+       (flet ((frob (kind addr)
+                (when addr
+                  (rec :name (zone-parse-host kind name)
+                       :type rrtype
+                       :data addr))))
+         (frob "net" base)
+         (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn)))
+         (frob "bcast" (ipnet-broadcast ipn)))))))
+

 (defzoneparse (:rev :reverse) (name data rec)
 (defzoneparse (:rev :reverse) (name data rec)

-  ":reverse ((NET :bytes BYTES) ZONE*)"
+  ":reverse ((NET &key :prefix-bits :family) ZONE*)
+
+   Add a reverse record each host in the ZONEs (or all zones) that lies
+   within NET."

   (setf data (listify data))
   (setf data (listify data))

-  (destructuring-bind
-      (net &key bytes)
+  (destructuring-bind (net &key prefix-bits (family *address-family*))

       (listify (car data))
       (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)
+
+    (dolist (ipn (net-parse-to-ipnets net family))
+      (let* ((seen (make-hash-table :test #'equal))
+            (width (ipnet-width ipn))
+            (frag-len (if prefix-bits (- width prefix-bits)
+                          (ipnet-changeable-bits width (ipnet-mask ipn)))))
+       (dolist (z (or (cdr data) (hash-table-keys *zones*)))
+         (dolist (zr (zone-records (zone-find z)))
+           (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn)))
+                      (zr-make-ptr-p zr)
+                      (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
+             (let* ((frag (reverse-domain-fragment (zr-data zr)
+                                                   0 frag-len))
+                    (name (concatenate 'string frag "." name)))
+               (unless (gethash name seen)
+                 (rec :name name :type :ptr
+                      :ttl (zr-ttl zr) :data (zr-name zr))
+                 (setf (gethash name seen) t))))))))))
+
+(defzoneparse :multi (name data rec :zname zname :ttl ttl)
+  ":multi (((NET*) &key :start :end :family :suffix) . REC)
+
+   Output multiple records covering a portion of the reverse-resolution
+   namespace corresponding to the particular NETs.  The START and END bounds
+   default to the most significant variable component of the
+   reverse-resolution domain.
+
+   The REC tail is a sequence of record forms (as handled by
+   `zone-process-records') to be emitted for each covered address.  Within
+   the bodies of these forms, the symbol `*' will be replaced by the
+   domain-name fragment corresponding to the current host, optionally
+   followed by the SUFFIX.
+
+   Examples:
+
+       (:multi ((delegated-subnet :start 8)
+                :ns (some.ns.delegated.example :ip \"169.254.5.2\")))
+
+       (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\")
+                :cname *))
+
+   Obviously, nested `:multi' records won't work well."
+
+  (destructuring-bind (nets &key start end (family *address-family*) suffix)

       (listify (car data))
       (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))))))))
+    (dolist (net (listify nets))
+      (dolist (ipn (net-parse-to-ipnets net family))
+       (let* ((addr (ipnet-net ipn))
+              (width (ipaddr-width addr))
+              (comp-width (reverse-domain-component-width addr))
+              (end (round-up (or end
+                                 (ipnet-changeable-bits width
+                                                        (ipnet-mask ipn)))
+                             comp-width))
+              (start (round-down (or start (- end comp-width))
+                                 comp-width))
+              (map (ipnet-host-map ipn)))
+         (multiple-value-bind (host-step host-limit)
+             (ipnet-index-bounds map start end)
+           (do ((index 0 (+ index host-step)))
+               ((> index host-limit))
+             (let* ((addr (ipnet-index-host map index))
+                    (frag (reverse-domain-fragment addr start end))
+                    (target (concatenate 'string
+                                         (zone-make-name
+                                          (if (not suffix) frag
+                                              (concatenate 'string
+                                                           frag "." suffix))
+                                          zname)
+                                         ".")))
+               (dolist (zr (zone-parse-records (zone-make-name frag zname)
+                                               ttl
+                                               (subst target '*
+                                                      (cdr data))))
+                 (rec :name (zr-name zr)
+                      :type (zr-type zr)
+                      :data (zr-data zr)
+                      :ttl (zr-ttl zr)
+                      :make-ptr-p (zr-make-ptr-p zr)))))))))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; 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 "~
+(export 'zone-write)
+(defgeneric zone-write (format zone stream)
+  (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
+
+(defvar *writing-zone* nil
+  "The zone currently being written.")
+
+(defvar *zone-output-stream* nil
+  "Stream to write zone data on.")
+
+(defmethod zone-write :around (format zone stream)
+  (declare (ignore format))
+  (let ((*writing-zone* zone)
+       (*zone-output-stream* stream))
+    (call-next-method)))
+
+(export 'zone-save)
+(defun zone-save (zones &key (format :bind))
+  "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
+                                                (zone-file-name z :zone))))
+         (zone-write format zz stream))))))
+
+;;;--------------------------------------------------------------------------
+;;; Bind format output.
+
+(export 'bind-hostname)
+(defun bind-hostname (hostname)
+  (if (not hostname)
+      "@"
+      (let* ((h (string-downcase (stringify hostname)))
+            (hl (length h))
+            (r (string-downcase (zone-name *writing-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 "."))))))
+
+(export 'bind-record)
+(defgeneric bind-record (type zr))
+
+(defmethod zone-write ((format (eql :bind)) zone stream)
+  (format stream "~

 ;;; Zone file `~(~A~)'
 ;;;   (generated ~A)
 
 ;;; Zone file `~(~A~)'
 ;;;   (generated ~A)
 


@@ -769,55 +947,70 @@ (defun zone-write (zone &optional (stream *standard-output*))
            (zone-name zone)
            (iso-date :now :datep t :timep t)
            (zone-default-ttl zone))
            (zone-name zone)
            (iso-date :now :datep t :timep t)
            (zone-default-ttl zone))

-    (let ((soa (zone-soa zone)))
+  (let* ((soa (zone-soa zone))
+        (admin (let* ((name (soa-admin soa))
+                      (at (position #\@ name))
+                      (copy (format nil "~(~A~)." name)))
+                 (when at
+                   (setf (char copy at) #\.))
+                 copy)))

       (format stream "~
       (format stream "~

-~A~30TIN SOA~40T~A ~A (
+~A~30TIN SOA~40T~A (
+~55@A~60T ;administrator

 ~45T~10D~60T ;serial
 ~45T~10D~60T ;refresh
 ~45T~10D~60T ;retry
 ~45T~10D~60T ;expire
 ~45T~10D )~60T ;min-ttl~2%"
 ~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))
+             (bind-hostname (zone-name zone))
+             (bind-hostname (soa-source soa))
+             admin

              (soa-serial soa)
              (soa-refresh soa)
              (soa-retry soa)
              (soa-expire soa)
              (soa-min-ttl 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))))))
+  (dolist (zr (zone-records zone))
+    (bind-record (zr-type zr) zr)))
+
+(export 'bind-format-record)
+(defun bind-format-record (name ttl type format args)
+  (format *zone-output-stream*
+         "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
+         (bind-hostname name)
+         (and (/= ttl (zone-default-ttl *writing-zone*))
+              ttl)
+         (string-upcase (symbol-name type))
+         format args))
+
+(export 'bind-record-type)
+(defgeneric bind-record-type (type)
+  (:method (type) type))
+
+(export 'bind-record-format-args)
+(defgeneric bind-record-format-args (type data)
+  (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
+  (:method ((type (eql :aaaa)) data) (list "~A" (ipaddr-string data)))
+  (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
+  (:method ((type (eql :mx)) data)
+    (list "~2D ~A" (cdr data) (bind-hostname (car data))))
+  (:method ((type (eql :srv)) data)
+    (destructuring-bind (prio weight port host) data
+      (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
+  (:method ((type (eql :sshfp)) data)
+    (cons "~2D ~2D ~A" data))
+  (:method ((type (eql :txt)) data)
+    (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
+         (mapcar #'stringify (listify data)))))
+
+(defmethod bind-record (type zr)
+  (destructuring-bind (format &rest args)
+      (bind-record-format-args type (zr-data zr))
+    (bind-format-record (zr-name zr)
+                       (zr-ttl zr)
+                       (bind-record-type type)
+                       format args)))

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