X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/ab87c7bf4977fe6b89e8e6d1a45c300e341d366a..590ad96179e11b59ae83bac2072a89ba1d529212:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 6b11880..74ecf58 100644
--- a/zone.lisp
+++ b/zone.lisp
@@ -35,7 +35,7 @@
 	     #:*default-mx-priority* #:*default-zone-admin*
 	   #:*zone-output-path*
 	   #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
-	   #:defrevzone #:zone-save
+	   #:defrevzone #:zone-save #:zone-make-name
 	   #:defzoneparse #:zone-parse-host
 	   #:timespec-seconds #:make-zone-serial))
 
@@ -200,7 +200,7 @@
   (name '<unnamed>)
   ttl
   type
-  (defsubp nil)
+  (make-ptr-p nil)
   data)
 
 (defstruct (zone-subdomain (:conc-name zs-))
@@ -246,31 +246,27 @@
 				     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)
+			      (zs-ttl s))
 		     (process (zs-records s)
 			      (cons (zs-name s) dom)
-			      (zs-ttl s)
-			      t))
+			      (zs-ttl s)))
 		 (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))))
 	       (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;
@@ -451,10 +447,18 @@
 		      :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:
@@ -466,47 +470,47 @@
 
    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 (body decls doc) body
-      (with-gensyms (col tname ttype tttl tdata tdefsubp i)
+      (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))
+			(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)))
@@ -515,23 +519,13 @@
 		 (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))
@@ -579,9 +573,13 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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"
@@ -641,23 +639,25 @@
     (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])*)"