;;; 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.
#:*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*
+ #:*preferred-subnets* #:zone-preferred-subnet-p
+ #:preferred-subnet-case
+ #: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)
;;;--------------------------------------------------------------------------
;;; Zone defaults. It is intended that scripts override these.
+#+ecl
+(cffi:defcfun gethostname :int
+ (name :pointer)
+ (len :uint))
+
(defvar *default-zone-source*
- (let ((hn (unix:unix-gethostname)))
+ (let ((hn #+cmu (unix:unix-gethostname)
+ #+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.")
(defvar *default-mx-priority* 50
"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.
(name '<unnamed>)
ttl
type
- (defsubp nil)
+ (make-ptr-p nil)
data)
(defstruct (zone-subdomain (:conc-name zs-))
ttl
records)
+(defvar *zone-output-path* *default-pathname-defaults*
+ "Pathname defaults to merge into output files.")
+
+(defvar *preferred-subnets* nil
+ "Subnets to prefer when selecting defaults.")
+
;;;--------------------------------------------------------------------------
;;; 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-preferred-subnet-p (name)
+ "Answer whether NAME (a string or symbol) names a preferred subnet."
+ (member name *preferred-subnets* :test #'string-equal))
+
+(defmacro preferred-subnet-case (&body clauses)
+ "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose
+ SUBNETS (a list or single symbol, not evaluated) are considered preferred
+ by zone-preferred-subnet-p. If SUBNETS is the symbol t then the clause
+ always matches."
+ `(cond
+ ,@(mapcar (lambda (clause)
+ (let ((subnets (car clause)))
+ (cons (cond ((eq subnets t)
+ t)
+ ((listp subnets)
+ `(or ,@(mapcar (lambda (subnet)
+ `(zone-preferred-subnet-p
+ ',subnet))
+ subnets)))
+ (t
+ `(zone-preferred-subnet-p ',subnets)))
+ (cdr clause))))
+ clauses)))
+
(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."
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)
- (process (zs-records s)
- (cons (zs-name s) dom)
- (zs-ttl s)
- t))
- (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))))
+ (let ((preferred nil))
+ (dolist (s sub)
+ (when (some #'zone-preferred-subnet-p
+ (listify (zs-name s)))
+ (setf preferred s)))
+ (unless preferred
+ (setf preferred (car sub)))
+ (when preferred
+ (process (zs-records preferred)
+ dom
+ (zs-ttl preferred))))
+ (let ((name (and dom
+ (string-downcase
+ (join-strings #\. (reverse dom))))))
+ (dolist (zr top)
+ (setf (zr-name zr) name)
+ (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;
(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."
until (zerop (logand mask (ash #xff (* 8 i))))
collect (logand #xff (ash net (* -8 i))))))))
-(defun zone-cidr-delegation (data name ttl list)
- "Given :cidr-delegation info DATA, for a record called NAME and the current
- TTL, write lots of CNAME records to LIST."
- (destructuring-bind
- (net &key bytes)
- (listify (car data))
- (setf net (zone-parse-net net name))
- (unless bytes
- (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
- (dolist (map (cdr data))
- (destructuring-bind
- (tnet &optional tdom)
- (listify map)
- (setf tnet (zone-parse-net tnet name))
- (unless (ipnet-subnetp net tnet)
- (error "~A is not a subnet of ~A."
- (ipnet-pretty tnet)
- (ipnet-pretty net)))
- (unless tdom
- (setf tdom
- (join-strings #\.
- (list (zone-cidr-delg-default-name tnet bytes)
- name))))
- (setf tdom (string-downcase tdom))
- (dotimes (i (ipnet-hosts tnet))
- (let* ((addr (ipnet-host tnet i))
- (tail (join-strings #\.
- (loop
- for i from 0 below bytes
- collect
- (logand #xff
- (ash addr (* 8 i)))))))
- (collect (make-zone-record
- :name (join-strings #\.
- (list tail name))
- :type :cname
- :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.
:min-ttl (timespec-seconds min-ttl)
:serial serial))))
+(defun zone-make-name (prefix zone-name)
+ (if (or (not prefix) (string= prefix "@"))
+ zone-name
+ (let ((len (length prefix)))
+ (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
+ (join-strings #\. (list prefix zone-name))
+ prefix))))
+
(defmacro defzoneparse (types (name data list
- &key (zname (gensym "ZNAME"))
- (ttl (gensym "TTL"))
- (defsubp (gensym "DEFSUBP")))
+ &key (prefix (gensym "PREFIX"))
+ (zname (gensym "ZNAME"))
+ (ttl (gensym "TTL")))
&body body)
"Define a new zone record type (or TYPES -- a list of synonyms is
permitted). The arguments are as follows:
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.
+ PREFIX The prefix tag used in the original form.
+
ZNAME The name of the zone being constructed.
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
+ You get to choose your own names for these. ZNAME, PREFIX 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 :make-ptr-p)
- Except for defsubp, these default to the above arguments (even if you
- didn't accept the arguments)."
+ These (except MAKE-PTR-P, which defaults to nil) 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))))
- (multiple-value-bind (doc decls body) (parse-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 tmakeptrp i)
`(progn
(dolist (,i ',types)
(setf (get ,i 'zone-parse) ',func))
- (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
+ (defun ,func (,prefix ,zname ,data ,ttl ,col)
,@doc
,@decls
- (declare (ignorable ,zname ,defsubp))
- (flet ((,list (&key ((:name ,tname) ,name)
- ((:type ,ttype) ,type)
- ((:data ,tdata) ,data)
- ((:ttl ,tttl) ,ttl)
- ((:defsubp ,tdefsubp) nil))
- (collect (make-zone-record :name ,tname
- :type ,ttype
- :data ,tdata
- :ttl ,tttl
- :defsubp ,tdefsubp)
- ,col)))
- ,@body))
- ',type)))))
+ (let ((,name (zone-make-name ,prefix ,zname)))
+ (flet ((,list (&key ((:name ,tname) ,name)
+ ((:type ,ttype) ,type)
+ ((:data ,tdata) ,data)
+ ((:ttl ,tttl) ,ttl)
+ ((:make-ptr-p ,tmakeptrp) nil))
+ #+cmu (declare (optimize ext:inhibit-warnings))
+ (collect (make-zone-record :name ,tname
+ :type ,ttype
+ :data ,tdata
+ :ttl ,tttl
+ :make-ptr-p ,tmakeptrp)
+ ,col)))
+ ,@body)))
+ ',type)))))
(defun zone-parse-records (zone records)
(let ((zname (zone-name zone)))
(let ((func (or (get (zr-type zr) 'zone-parse)
(error "No parser for record ~A."
(zr-type zr))))
- (name (and (zr-name zr)
- (stringify (zr-name zr)))))
- (if (or (not name)
- (string= name "@"))
- (setf name zname)
- (let ((len (length name)))
- (if (or (zerop len)
- (char/= (char name (1- len)) #\.))
- (setf name (join-strings #\.
- (list name zname))))))
+ (name (and (zr-name zr) (stringify (zr-name zr)))))
(funcall func
name
+ zname
(zr-data zr)
(zr-ttl zr)
- rec
- zname
- (zr-defsubp zr)))))
+ rec))))
(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)
;;;--------------------------------------------------------------------------
;;; 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) :make-ptr-p t))
+
+(defzoneparse :svc (name data rec)
+ ":svc IPADDR"
+ (rec :type :a :data (parse-ipaddr data)))
(defzoneparse :ptr (name data rec :zname zname)
":ptr HOST"
(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))
(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)
+ (zr-make-ptr-p zr)
+ (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])*)"
(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
;;;--------------------------------------------------------------------------
;;; 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)
-$ORIGIN ~@0*~(~A.~)
-$TTL ~@2*~D~2%"
+$ORIGIN ~0@*~(~A.~)
+$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
~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))
- (case (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
- (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
- (format nil
- "~(~A~).zone"
- z))))
- (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 --------------------------------------------------
~mdw / zone / blobdiff