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 74ecf58..0e579dc 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -34,6 +34,7 @@
             #:*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
@@ -213,6 +214,9 @@
 (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.
 
@@ -222,6 +226,10 @@
                                  :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."
@@ -249,19 +257,23 @@
           (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)