chiark / gitweb /
zone, frontend: Open up the writing of zones to files.
authorMark Wooding <mdw@distorted.org.uk>
Tue, 26 Jun 2007 16:43:12 +0000 (17:43 +0100)
committerMark Wooding <mdw@distorted.org.uk>
Tue, 26 Jun 2007 16:43:12 +0000 (17:43 +0100)
All file writing is now done using generic functions, parameterized by a
format keyword.  Writing of the default BIND format zone files is also
handled by generic functions, dispatched based on the record types.

frontend.lisp
zone.lisp

index ef9c090..46c5a36 100644 (file)
@@ -30,6 +30,8 @@ (in-package #:zone.frontend)
 
 (defvar opt-zones nil
   "Which zones to be emitted.")
+(defvar opt-format :bind
+  "Which format to use on output.")
 
 (eval-when (:compile-toplevel :load-toplevel)
   (defopthandler dir (var arg) ()
@@ -54,6 +56,20 @@ (define-program
                      (#\d "directory" (:arg "DIRECTORY")
                           (dir *zone-output-path*)
                           "Write zone and serial files to DIRECTORY.")
+                     (#\F "format" (:arg "FORMAT")
+                          (keyword opt-format
+                                   (delete-duplicates
+                                    (loop for method in
+                                          (pcl:generic-function-methods
+                                           #'zone:zone-write)
+                                          for specs =
+                                          (pcl:method-specializers method)
+                                          if (typep (car specs)
+                                                    'pcl:eql-specializer)
+                                          collect
+                                          (pcl:eql-specializer-object
+                                           (car specs)))))
+                          "Format to use for output.")
                      (#\z "zone" (:arg "NAME") (list opt-zones)
                           "Write information about zone NAME.")))
 
@@ -72,6 +88,6 @@ (defun main ()
                                       :use '(#:common-lisp #:net #:zone))))
          (load f :verbose nil :print nil :if-does-not-exist :error)
          (delete-package *package*)))
-      (zone-save opt-zones))))
+      (zone-save opt-zones :format opt-format))))
 
 ;;;----- That's all, folks --------------------------------------------------
index be6a16e..c830a11 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -39,6 +39,8 @@ (defpackage #:zone
           #: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)
@@ -738,34 +740,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)
 
@@ -774,7 +795,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
@@ -782,42 +809,46 @@ (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 :txt)) data) (list "~S" (stringify data))))
 
 ;;;----- That's all, folks --------------------------------------------------