chiark / gitweb /
zone, serv: Add support for SRV records.
[zone] / zone.lisp
index adcfb7e..2e108ba 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
 ;;; 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)
+  (:use #:common-lisp
+       #:mdw.base #:mdw.str #:collect #:safely
+       #:net #:services)
   (: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
+          #:*zone-output-path*
+          #:*preferred-subnets* #:zone-preferred-subnet-p
+          #:preferred-subnet-case
+          #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
+          #:defrevzone #:zone-save #:zone-make-name
           #:defzoneparse #:zone-parse-host
+          #:bind-hostname #:bind-record #:bind-format-record
+          #:bind-record-type #:bind-record-format-args
           #:timespec-seconds #:make-zone-serial))
 
 (in-package #:zone)
@@ -181,35 +188,6 @@ (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)
@@ -228,7 +206,7 @@ (defstruct (zone-record (:conc-name zr-))
   (name '<unnamed>)
   ttl
   type
-  (defsubp nil)
+  (make-ptr-p nil)
   data)
 
 (defstruct (zone-subdomain (:conc-name zs-))
@@ -238,9 +216,45 @@ (defstruct (zone-subdomain (:conc-name zs-))
   ttl
   records)
 
+(defvar *zone-output-path* *default-pathname-defaults*
+  "Pathname defaults to merge into output files.")
+
+(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))
+                  *zone-output-path*))
+
+(defun zone-preferred-subnet-p (name)
+  "Answer whether NAME (a string or symbol) names a preferred subnet."
+  (member name *preferred-subnets* :test #'string-equal))
+
+(defmacro preferred-subnet-case (&body clauses)
+  "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose
+   SUBNETS (a list or single symbol, not evaluated) are considered preferred
+   by zone-preferred-subnet-p.  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)))
+
 (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."
@@ -265,31 +279,31 @@ (defun zone-process-records (rec ttl func)
                                     sub)))
                         (t
                          (error "Unexpected record form ~A" (car r))))))))
-          (process (rec dom ttl defsubp)
+          (process (rec dom ttl)
             (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 nil))
+                    (dolist (s sub)
+                      (when (some #'zone-preferred-subnet-p
+                                  (listify (zs-name s)))
+                        (setf preferred s)))
+                    (unless preferred
+                      (setf preferred (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)
-                         (zs-ttl s)
-                         defsubp)))))
-    (process rec nil ttl nil)))
+                         (zs-ttl s))))))
+    (process rec nil ttl)))
 
 (defun zone-parse-host (f zname)
   "Parse a host name F: if F ends in a dot then it's considered absolute;
@@ -349,44 +363,6 @@ (defun zone-net-from-name (name)
     (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."
@@ -405,46 +381,35 @@ (defun zone-cidr-delg-default-name (ipn bytes)
                      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)))))))
-                                                 
+;;;--------------------------------------------------------------------------
+;;; 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 (zone-file-name name :serial))
+        (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 form parsing.
 
@@ -479,10 +444,18 @@ (defun zone-parse-head (head)
                      :min-ttl (timespec-seconds min-ttl)
                      :serial serial))))
 
+(defun zone-make-name (prefix zone-name)
+  (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))))
+
 (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)
   "Define a new zone record type (or TYPES -- a list of synonyms is
    permitted).  The arguments are as follows:
@@ -490,51 +463,52 @@                               (defsubp (gensym "DEFSUBP")))
    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.
 
+   PREFIX      The prefix tag used in the original form.
+
    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
 
-     (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))))
-    (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))
-          (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
+          (defun ,func (,prefix ,zname ,data ,ttl ,col)
             ,@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)))))
+            (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)))))
 
 (defun zone-parse-records (zone records)
   (let ((zname (zone-name zone)))
@@ -543,26 +517,16 @@ (defun zone-parse-records (zone records)
                 (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))))))
+                      (name (and (zr-name zr) (stringify (zr-name zr)))))
                   (funcall func
                            name
+                           zname
                            (zr-data zr)
                            (zr-ttl zr)
-                           rec
-                           zname
-                           (zr-defsubp zr)))))
+                           rec))))
          (zone-process-records records
                                (zone-default-ttl zone)
-                               #'parse-record ))
+                               #'parse-record))
       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 
 (defun zone-parse (zf)
@@ -607,9 +571,13 @@ (defmacro defrevzone (head &rest zf)
 ;;;--------------------------------------------------------------------------
 ;;; Zone record parsers.
 
-(defzoneparse :a (name data rec :defsubp defsubp)
+(defzoneparse :a (name data rec)
   ":a IPADDR"
-  (rec :data (parse-ipaddr data) :defsubp defsubp))
+  (rec :data (parse-ipaddr data) :make-ptr-p t))
+
+(defzoneparse :svc (name data rec)
+  ":svc IPADDR"
+  (rec :type :a :data (parse-ipaddr data)))
 
 (defzoneparse :ptr (name data rec :zname zname)
   ":ptr HOST"
@@ -646,6 +614,31 @@ (defzoneparse :alias (name data rec :zname zname)
         :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 (rec :name host :type :a :data (parse-ipaddr ip)))
+               (rec :name rname
+                    :data (list prio weight port host))))))))))
+
 (defzoneparse :net (name data rec)
   ":net (NETWORK*)"
   (dolist (net (listify data))
@@ -659,7 +652,7 @@ (defzoneparse :net (name data rec)
       (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))
@@ -669,23 +662,25 @@ (defzoneparse (:rev :reverse) (name data rec)
     (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)))))))
+    (let ((seen (make-hash-table :test #'equal)))
+      (dolist (z (or (cdr data)
+                    (hash-table-keys *zones*)))
+       (dolist (zr (zone-records (zone-find z)))
+         (when (and (eq (zr-type zr) :a)
+                    (zr-make-ptr-p zr)
+                    (ipaddr-networkp (zr-data zr) net))
+           (let ((name (string-downcase
+                        (join-strings
+                         #\.
+                         (collecting ()
+                           (dotimes (i bytes)
+                             (collect (logand #xff (ash (zr-data zr)
+                                                        (* -8 i)))))
+                           (collect name))))))
+             (unless (gethash name seen)
+               (rec :name name :type :ptr
+                    :ttl (zr-ttl zr) :data (zr-name zr))
+               (setf (gethash name seen) t)))))))))
 
 (defzoneparse (:cidr-delegation :cidr) (name data rec)
   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
@@ -703,7 +698,7 @@ (defzoneparse (:cidr-delegation :cidr) (name data rec)
        (unless (ipnet-subnetp net tnet)
          (error "~A is not a subnet of ~A."
                 (ipnet-pretty tnet)
-                (ipnet-pretty net)))            
+                (ipnet-pretty net)))
        (unless tdom
          (with-ipnet (net mask) tnet
            (setf tdom
@@ -733,34 +728,53 @@ (defzoneparse (:cidr-delegation :cidr) (name data rec)
 ;;;--------------------------------------------------------------------------
 ;;; 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 "~
+(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)
+  (let ((*writing-zone* zone)
+       (*zone-output-stream* stream))
+    (call-next-method)))
+
+(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.
+
+(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 "."))))))
+
+(defmethod zone-write ((format (eql :bind)) zone stream)
+  (format stream "~
 ;;; Zone file `~(~A~)'
 ;;;   (generated ~A)
 
@@ -769,7 +783,13 @@ (defun zone-write (zone &optional (stream *standard-output*))
            (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 "~
 ~A~30TIN SOA~40T~A ~A (
 ~45T~10D~60T ;serial
@@ -777,47 +797,49 @@ (defun zone-write (zone &optional (stream *standard-output*))
 ~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)))
-    (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)))
+
+(defgeneric bind-record (type zr))
+
+(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))
+
+(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)))
+
+(defgeneric bind-record-type (type)
+  (:method (type) type))
+
+(defgeneric bind-record-format-args (type data)
+  (:method ((type (eql :a)) 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 :txt)) data) (list "~S" (stringify data))))
 
 ;;;----- That's all, folks --------------------------------------------------