From a567a3bce51edcee4bd83afd9eea82ea42b2ce1f Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 26 Jun 2007 17:43:12 +0100 Subject: [PATCH] zone, frontend: Open up the writing of zones to files. 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 | 18 ++++++- zone.lisp | 153 +++++++++++++++++++++++++++++++++++----------------------- 2 files changed, 109 insertions(+), 62 deletions(-) diff --git a/frontend.lisp b/frontend.lisp index ef9c090..46c5a36 100644 --- a/frontend.lisp +++ b/frontend.lisp @@ -30,6 +30,8 @@ (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 @@ (#\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 @@ :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 -------------------------------------------------- diff --git a/zone.lisp b/zone.lisp index be6a16e..c830a11 100644 --- a/zone.lisp +++ b/zone.lisp @@ -39,6 +39,8 @@ #: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 @@ ;;;-------------------------------------------------------------------------- ;;; 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 @@ $TTL ~2@*~D~2%" (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 @@ $TTL ~2@*~D~2%" ~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 -------------------------------------------------- -- 2.11.0