X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/5bf80328af386b6737e9c5a75ad1d0d95bf5f38b..716105aa3a725242d5fac82bab8db82e0bb46995:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 0ea9360..2e108ba 100644
--- a/zone.lisp
+++ b/zone.lisp
@@ -27,16 +27,22 @@
 ;;; 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-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)
@@ -200,6 +206,7 @@ (defstruct (zone-record (:conc-name zr-))
   (name '<unnamed>)
   ttl
   type
+  (make-ptr-p nil)
   data)
 
 (defstruct (zone-subdomain (:conc-name zs-))
@@ -212,6 +219,9 @@ (defstruct (zone-subdomain (:conc-name zs-))
 (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 +231,30 @@ (defun zone-file-name (zone type)
 				  :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."
@@ -248,19 +282,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)
-		   (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)
@@ -343,46 +381,6 @@ (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.
 
@@ -481,15 +479,15 @@ (defmacro defzoneparse (types (name data list
    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 +498,14 @@ 	   (defun ,func (,prefix ,zname ,data ,ttl ,col)
 	       (flet ((,list (&key ((:name ,tname) ,name)
 				   ((:type ,ttype) ,type)
 				   ((:data ,tdata) ,data)
-				   ((:ttl ,tttl) ,ttl))
+				   ((: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)
+						   :ttl ,tttl
+						   :make-ptr-p ,tmakeptrp)
 				 ,col)))
 		 ,@body)))
 	  ',type)))))
@@ -572,7 +573,11 @@ (defmacro defrevzone (head &rest zf)
 
 (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"
@@ -609,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))
@@ -637,6 +667,7 @@ (defzoneparse (:rev :reverse) (name data rec)
 		     (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
@@ -697,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)
 
@@ -733,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
@@ -741,42 +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))
-      (ecase (zr-type zr)
-	(:a
-	 (printrec zr)
-	 (format stream "~A~%" (ipaddr-string (zr-data zr))))
-	((:ptr :cname :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
-						 (zone-file-name z :zone))))
-	  (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 --------------------------------------------------