X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/e926682641174e963e81bbe18ab1df3cb90db0f3..4e7e3780c0f92094c6def85910e14901b9e1070f:/zone.lisp diff --git a/zone.lisp b/zone.lisp index adcfb7e..f3d85d0 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)) @@ -181,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) @@ -228,7 +200,6 @@ (name ') ttl type - (defsubp nil) data) (defstruct (zone-subdomain (:conc-name zs-)) @@ -238,9 +209,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." @@ -265,31 +245,27 @@ sub))) (t (error "Unexpected record form ~A" (car r)))))))) - (process (rec dom ttl defsubp) + (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) - defsubp) + (zs-ttl s)) (process (zs-records s) (cons (zs-name s) dom) - (zs-ttl s) - t)) + (zs-ttl s))) (let ((name (and dom (string-downcase (join-strings #\. (reverse dom)))))) (dolist (zr top) (setf (zr-name zr) name) - (setf (zr-defsubp zr) defsubp) (funcall func zr)))) (dolist (s sub) (process (zs-records s) (cons (zs-name s) dom) - (zs-ttl s) - defsubp))))) - (process rec nil ttl nil))) + (zs-ttl s)))))) + (process rec nil ttl))) (defun zone-parse-host (f zname) "Parse a host name F: if F ends in a dot then it's considered absolute; @@ -349,44 +325,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." @@ -422,7 +360,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 #\. @@ -444,7 +382,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,8 +448,7 @@ (defmacro defzoneparse (types (name data list &key (zname (gensym "ZNAME")) - (ttl (gensym "TTL")) - (defsubp (gensym "DEFSUBP"))) + (ttl (gensym "TTL"))) &body body) "Define a new zone record type (or TYPES -- a list of synonyms is permitted). The arguments are as follows: @@ -490,7 +456,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. @@ -498,40 +464,36 @@ TTL The TTL for this record. - DEFSUBP Whether this is the default subdomain for this entry. - - You get to choose your own names for these. ZNAME, TTL and DEFSUBP are - optional: you don't have to accept them if you're not interested. + You get to choose your own names for these. ZNAME and TTL are optional: + you don't have to accept them if you're not interested. 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 :defsubp) + (LIST &key :name :type :data :ttl) - Except for defsubp, these default to the above arguments (even if you - didn't accept the arguments)." + These 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 (doc decls body body) - (with-gensyms (col tname ttype tttl tdata tdefsubp i) + (with-parsed-body (body decls doc) body + (with-gensyms (col tname ttype tttl tdata i) `(progn (dolist (,i ',types) (setf (get ,i 'zone-parse) ',func)) - (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp) + (defun ,func (,name ,data ,ttl ,col ,zname) ,@doc ,@decls - (declare (ignorable ,zname ,defsubp)) + (declare (ignorable ,zname)) (flet ((,list (&key ((:name ,tname) ,name) ((:type ,ttype) ,type) ((:data ,tdata) ,data) - ((:ttl ,tttl) ,ttl) - ((:defsubp ,tdefsubp) nil)) + ((:ttl ,tttl) ,ttl)) (collect (make-zone-record :name ,tname :type ,ttype :data ,tdata - :ttl ,tttl - :defsubp ,tdefsubp) + :ttl ,tttl) ,col))) ,@body)) ',type))))) @@ -558,11 +520,10 @@ (zr-data zr) (zr-ttl zr) rec - zname - (zr-defsubp zr))))) + zname)))) (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) @@ -607,9 +568,9 @@ ;;;-------------------------------------------------------------------------- ;;; Zone record parsers. -(defzoneparse :a (name data rec :defsubp defsubp) +(defzoneparse :a (name data rec) ":a IPADDR" - (rec :data (parse-ipaddr data) :defsubp defsubp)) + (rec :data (parse-ipaddr data))) (defzoneparse :ptr (name data rec :zname zname) ":ptr HOST" @@ -659,7 +620,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)) @@ -669,23 +630,24 @@ (setf net (zone-parse-net net name)) (unless bytes (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) - (dolist (z (or (cdr data) - (hash-table-keys *zones*))) - (dolist (zr (zone-records (zone-find z))) - (when (and (eq (zr-type zr) :a) - (not (zr-defsubp zr)) - (ipaddr-networkp (zr-data zr) net)) - (rec :name (string-downcase - (join-strings - #\. - (collecting () - (dotimes (i bytes) - (collect (logand #xff (ash (zr-data zr) - (* -8 i))))) - (collect name)))) - :type :ptr - :ttl (zr-ttl zr) - :data (zr-name zr))))))) + (let ((seen (make-hash-table :test #'equal))) + (dolist (z (or (cdr data) + (hash-table-keys *zones*))) + (dolist (zr (zone-records (zone-find z))) + (when (and (eq (zr-type zr) :a) + (ipaddr-networkp (zr-data zr) net)) + (let ((name (string-downcase + (join-strings + #\. + (collecting () + (dotimes (i bytes) + (collect (logand #xff (ash (zr-data zr) + (* -8 i))))) + (collect name)))))) + (unless (gethash name seen) + (rec :name name :type :ptr + :ttl (zr-ttl zr) :data (zr-name zr)) + (setf (gethash name seen) t))))))))) (defzoneparse (:cidr-delegation :cidr) (name data rec) ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)" @@ -703,7 +665,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 @@ -786,14 +748,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 @@ -815,9 +774,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 --------------------------------------------------