X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/5bf80328af386b6737e9c5a75ad1d0d95bf5f38b..8ce7eb9bf5fdb91883c53855ff605505ed064cea:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 0ea9360..0e579dc 100644
--- 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
@@ -200,6 +201,7 @@
   (name '<unnamed>)
   ttl
   type
+  (make-ptr-p nil)
   data)
 
 (defstruct (zone-subdomain (:conc-name zs-))
@@ -212,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.
 
@@ -221,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."
@@ -248,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)
@@ -481,15 +494,15 @@
    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)
+     (LIST &key :name :type :data :ttl :make-ptr-p)
 
-   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 (body decls doc) body
-      (with-gensyms (col tname ttype tttl tdata i)
+      (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 	`(progn
 	   (dolist (,i ',types)
 	     (setf (get ,i 'zone-parse) ',func))
@@ -500,11 +513,13 @@
 	       (flet ((,list (&key ((:name ,tname) ,name)
 				   ((:type ,ttype) ,type)
 				   ((:data ,tdata) ,data)
-				   ((:ttl ,tttl) ,ttl))
+				   ((:ttl ,tttl) ,ttl)
+				   ((:make-ptr-p ,tmakeptrp) nil))
 			(collect (make-zone-record :name ,tname
 						   :type ,ttype
 						   :data ,tdata
-						   :ttl ,tttl)
+						   :ttl ,tttl
+						   :make-ptr-p ,tmakeptrp)
 				 ,col)))
 		 ,@body)))
 	  ',type)))))
@@ -572,7 +587,11 @@
 
 (defzoneparse :a (name data rec)
   ":a IPADDR"
-  (rec :data (parse-ipaddr data)))
+  (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"
@@ -637,6 +656,7 @@
 		     (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