zone: Change default subnet selection.

We now have a concept of `preferred subnets'.  If a record has a subnet
whose name is on the list *preferred-subnets*, and no explicit default
record, then the record for the first such subnet is used as the
default.  If no preferred subnet is found, then the first listed subnet
is used, as before.

The objective is to make describing split-horizon DNS systems easier.

diff --git a/zone.lisp b/zone.lisp
index 74ecf58dfe1baf811b710b0bfef4f0ac4d96cb0e..0e579dc95bbfc87608cec558689ed20109aba51d 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -34,6 +34,7 @@ (defpackage #:zone
             #:*default-zone-min-ttl* #:*default-zone-ttl*
             #:*default-mx-priority* #:*default-zone-admin*
           #:*zone-output-path*
             #:*default-zone-min-ttl* #:*default-zone-ttl*
             #:*default-mx-priority* #:*default-zone-admin*
           #:*zone-output-path*

+          #:*preferred-subnets* #:zone-preferred-subnet-p

           #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
           #:defrevzone #:zone-save #:zone-make-name
           #:defzoneparse #:zone-parse-host
           #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
           #:defrevzone #:zone-save #:zone-make-name
           #:defzoneparse #:zone-parse-host


@@ -213,6 +214,9 @@ (defstruct (zone-subdomain (:conc-name zs-))
 (defvar *zone-output-path* *default-pathname-defaults*
   "Pathname defaults to merge into output files.")
 
 (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone infrastructure.
 


@@ -222,6 +226,10 @@ (defun zone-file-name (zone type)
                                  :type (string-downcase type))
                   *zone-output-path*))
 
                                  :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))
+

 (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."
 (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."


@@ -249,19 +257,23 @@ (defun zone-process-records (rec ttl func)
           (process (rec dom ttl)
             (multiple-value-bind (top sub) (sift rec ttl)
               (if (and dom (null top) sub)
           (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))
-                    (process (zs-records s)
-                             (cons (zs-name s) dom)
-                             (zs-ttl s)))
-                (let ((name (and dom
-                                 (string-downcase
-                                  (join-strings #\. (reverse dom))))))
-                  (dolist (zr top)
-                    (setf (zr-name zr) name)
-                    (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)
               (dolist (s sub)
                 (process (zs-records s)
                          (cons (zs-name s) dom)