X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/7d593efdac74772541cd65e959a890a70ffd8e97..ab87c7bf4977fe6b89e8e6d1a45c300e341d366a:/zone.lisp?ds=sidebyside

diff --git a/zone.lisp b/zone.lisp
index 64488c2..6b11880 100644
--- a/zone.lisp
+++ b/zone.lisp
@@ -13,12 +13,12 @@
 ;;; it under the terms of the GNU General Public License as published by
 ;;; the Free Software Foundation; either version 2 of the License, or
 ;;; (at your option) any later version.
-;;; 
+;;;
 ;;; This program is distributed in the hope that it will be useful,
 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU General Public License for more details.
-;;; 
+;;;
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
@@ -33,8 +33,9 @@
 	     #:*default-zone-retry* #:*default-zone-expire*
 	     #:*default-zone-min-ttl* #:*default-zone-ttl*
 	     #:*default-mx-priority* #:*default-zone-admin*
-	     #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
-	     #:defrevzone #:zone-save
+	   #:*zone-output-path*
+	   #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
+	   #:defrevzone #:zone-save
 	   #:defzoneparse #:zone-parse-host
 	   #:timespec-seconds #:make-zone-serial))
 
@@ -144,9 +145,18 @@
 ;;;--------------------------------------------------------------------------
 ;;; Zone defaults.  It is intended that scripts override these.
 
+#+ecl
+(cffi:defcfun gethostname :int
+  (name :pointer)
+  (len :uint))
+
 (defvar *default-zone-source*
   (let ((hn #+cmu (unix:unix-gethostname)
-	    #+clisp (unix:get-host-name)))
+	    #+clisp (unix:get-host-name)
+	    #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
+		    (let ((rc (gethostname buffer len)))
+		      (unless (zerop rc)
+			(error "gethostname(2) failed (rc = ~A)." rc))))))
     (and hn (concatenate 'string (canonify-hostname hn) ".")))
   "The default zone source: the current host's name.")
 
@@ -172,35 +182,6 @@
   "Default MX priority.")
 
 ;;;--------------------------------------------------------------------------
-;;; Serial numbering.
-
-(defun make-zone-serial (name)
-  "Given a zone NAME, come up with a new serial number.  This will (very
-   carefully) update a file ZONE.serial in the current directory."
-  (let* ((file (format nil "~(~A~).serial" name))
-	 (last (with-open-file (in file
-				   :direction :input
-				   :if-does-not-exist nil)
-		 (if in (read in)
-		     (list 0 0 0 0))))
-	 (now (multiple-value-bind
-		  (sec min hr dy mon yr dow dstp tz)
-		  (get-decoded-time)
-		(declare (ignore sec min hr dow dstp tz))
-		(list dy mon yr)))
-	 (seq (cond ((not (equal now (cdr last))) 0)
-		    ((< (car last) 99) (1+ (car last)))
-		    (t (error "Run out of sequence numbers for ~A" name)))))
-    (safely-writing (out file)
-      (format out
-	      ";; Serial number file for zone ~A~%~
-               ;;   (LAST-SEQ DAY MONTH YEAR)~%~
-               ~S~%"
-	      name
-	      (cons seq now)))
-    (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
-
-;;;--------------------------------------------------------------------------
 ;;; Zone variables and structures.
 
 (defvar *zones* (make-hash-table :test #'equal)
@@ -229,9 +210,18 @@
   ttl
   records)
 
+(defvar *zone-output-path* *default-pathname-defaults*
+  "Pathname defaults to merge into output files.")
+
 ;;;--------------------------------------------------------------------------
 ;;; Zone infrastructure.
 
+(defun zone-file-name (zone type)
+  "Choose a file name for a given ZONE and TYPE."
+  (merge-pathnames (make-pathname :name (string-downcase zone)
+				  :type (string-downcase type))
+		   *zone-output-path*))
+
 (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."
@@ -340,44 +330,6 @@
     (setf addr (ash addr (* 8 (- 4 n))))
     (make-ipnet addr (* 8 n))))
 
-(defun zone-reverse-records (records net list bytes dom)
-  "Construct a reverse zone given a forward zone's RECORDS list, the NET that
-   the reverse zone is to serve, a LIST to collect the records into, how many
-   BYTES of data need to end up in the zone, and the DOM-ain suffix."
-  (dolist (zr records)
-    (when (and (eq (zr-type zr) :a)
-	       (not (zr-defsubp zr))
-	       (ipaddr-networkp (zr-data zr) net))
-      (collect (make-zone-record
-		:name (string-downcase
-		       (join-strings
-			#\.
-			(collecting ()
-			  (dotimes (i bytes)
-			    (collect (logand #xff (ash (zr-data zr)
-						       (* -8 i)))))
-			  (collect dom))))
-		:type :ptr
-		:ttl (zr-ttl zr)
-		:data (zr-name zr))
-	       list))))
-
-(defun zone-reverse (data name list)
-  "Process a :reverse record's DATA, for a domain called NAME, and add the
-   records to the LIST."
-  (destructuring-bind
-      (net &key bytes zones)
-      (listify data)
-    (setf net (zone-parse-net net name))
-    (dolist (z (or (listify zones)
-		   (hash-table-keys *zones*)))
-      (zone-reverse-records (zone-records (zone-find z))
-			    net
-			    list
-			    (or bytes
-				(ipnet-changeable-bytes (ipnet-mask net)))
-			    name))))
-
 (defun zone-parse-net (net name)
   "Given a NET, and the NAME of a domain to guess from if NET is null, return
    the ipnet for the network."
@@ -413,7 +365,7 @@
 	(unless (ipnet-subnetp net tnet)
 	  (error "~A is not a subnet of ~A."
 		 (ipnet-pretty tnet)
-		 (ipnet-pretty net)))		 
+		 (ipnet-pretty net)))
 	(unless tdom
 	  (setf tdom
 		(join-strings #\.
@@ -435,7 +387,36 @@
 		      :ttl ttl
 		      :data (join-strings #\. (list tail tdom)))
 		     list)))))))
-						  
+
+;;;--------------------------------------------------------------------------
+;;; Serial numbering.
+
+(defun make-zone-serial (name)
+  "Given a zone NAME, come up with a new serial number.  This will (very
+   carefully) update a file ZONE.serial in the current directory."
+  (let* ((file (zone-file-name name :serial))
+	 (last (with-open-file (in file
+				   :direction :input
+				   :if-does-not-exist nil)
+		 (if in (read in)
+		     (list 0 0 0 0))))
+	 (now (multiple-value-bind
+		  (sec min hr dy mon yr dow dstp tz)
+		  (get-decoded-time)
+		(declare (ignore sec min hr dow dstp tz))
+		(list dy mon yr)))
+	 (seq (cond ((not (equal now (cdr last))) 0)
+		    ((< (car last) 99) (1+ (car last)))
+		    (t (error "Run out of sequence numbers for ~A" name)))))
+    (safely-writing (out file)
+      (format out
+	      ";; Serial number file for zone ~A~%~
+               ;;   (LAST-SEQ DAY MONTH YEAR)~%~
+               ~S~%"
+	      name
+	      (cons seq now)))
+    (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Zone form parsing.
 
@@ -481,7 +462,7 @@
    NAME		The name of the record to be added.
 
    DATA		The content of the record to be added (a single object,
-		unevaluated). 
+		unevaluated).
 
    LIST		A function to add a record to the zone.  See below.
 
@@ -504,7 +485,7 @@
   (setf types (listify types))
   (let* ((type (car types))
 	 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
-    (multiple-value-bind (doc decls body) (parse-body body)
+    (with-parsed-body (body decls doc) body
       (with-gensyms (col tname ttype tttl tdata tdefsubp i)
 	`(progn
 	   (dolist (,i ',types)
@@ -553,7 +534,7 @@
 			    (zr-defsubp zr)))))
 	  (zone-process-records records
 				(zone-default-ttl zone)
-				#'parse-record ))
+				#'parse-record))
       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 
 (defun zone-parse (zf)
@@ -650,7 +631,7 @@
       (rec :name (zone-parse-host "broadcast" name)
 	   :type :a
 	   :data (ipnet-broadcast n)))))
-  
+
 (defzoneparse (:rev :reverse) (name data rec)
   ":reverse ((NET :bytes BYTES) ZONE*)"
   (setf data (listify data))
@@ -694,7 +675,7 @@
 	(unless (ipnet-subnetp net tnet)
 	  (error "~A is not a subnet of ~A."
 		 (ipnet-pretty tnet)
-		 (ipnet-pretty net)))		 
+		 (ipnet-pretty net)))
 	(unless tdom
 	  (with-ipnet (net mask) tnet
 	    (setf tdom
@@ -777,14 +758,11 @@ $TTL ~2@*~D~2%"
 	      (soa-expire soa)
 	      (soa-min-ttl soa)))
     (dolist (zr (zone-records zone))
-      (case (zr-type zr)
+      (ecase (zr-type zr)
 	(:a
 	 (printrec zr)
 	 (format stream "~A~%" (ipaddr-string (zr-data zr))))
-	((:ptr :cname)
-	 (printrec zr)
-	 (format stream "~A~%" (fix-host (zr-data zr))))
-	(:ns
+	((:ptr :cname :ns)
 	 (printrec zr)
 	 (format stream "~A~%" (fix-host (zr-data zr))))
 	(:mx
@@ -806,9 +784,7 @@ $TTL ~2@*~D~2%"
 	(unless zz
 	  (error "Unknown zone `~A'." z))
 	(let ((stream (safely-open-output-stream safe
-						 (format nil
-							 "~(~A~).zone"
-							 z))))
+						 (zone-file-name z :zone))))
 	  (zone-write zz stream))))))
 
 ;;;----- That's all, folks --------------------------------------------------