zone: Allow control over output file names.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 64488c2..6b11880 100644 (file)
--- 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.
 ;;; 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.
 ;;; 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.
 ;;; 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*
             #:*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))
 
           #:defzoneparse #:zone-parse-host
           #:timespec-seconds #:make-zone-serial))
 


@@ -144,9 +145,18 @@
 ;;;--------------------------------------------------------------------------
 ;;; Zone defaults.  It is intended that scripts override these.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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)
 (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.")
 
     (and hn (concatenate 'string (canonify-hostname hn) ".")))
   "The default zone source: the current host's name.")
 


@@ -172,35 +182,6 @@
   "Default MX priority.")
 
 ;;;--------------------------------------------------------------------------
   "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)
 ;;; Zone variables and structures.
 
 (defvar *zones* (make-hash-table :test #'equal)


@@ -229,9 +210,18 @@
   ttl
   records)
 
   ttl
   records)
 

+(defvar *zone-output-path* *default-pathname-defaults*
+  "Pathname defaults to merge into output files.")
+

 ;;;--------------------------------------------------------------------------
 ;;; Zone infrastructure.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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."
 (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))))
 
     (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."
 (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)
        (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 #\.
        (unless tdom
          (setf tdom
                (join-strings #\.


@@ -435,7 +387,36 @@
                      :ttl ttl
                      :data (join-strings #\. (list tail tdom)))
                     list)))))))
                      :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.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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,
    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.
 
 
    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))))
   (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)
       (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)
                            (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)
       (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)))))
       (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))
 (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)
        (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
        (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))
              (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))))
        (: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
         (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
        (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 --------------------------------------------------
          (zone-write zz stream))))))
 
 ;;;----- That's all, folks --------------------------------------------------