#:*default-zone-min-ttl* #:*default-zone-ttl*
#:*default-mx-priority* #:*default-zone-admin*
#:*zone-output-path*
+ #:*preferred-subnets* #:zone-preferred-subnet-p
#:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
- #:defrevzone #:zone-save
+ #:defrevzone #:zone-save #:zone-make-name
#:defzoneparse #:zone-parse-host
#:timespec-seconds #:make-zone-serial))
(name '<unnamed>)
ttl
type
+ (make-ptr-p nil)
data)
(defstruct (zone-subdomain (:conc-name zs-))
(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.
: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))
+
(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."
(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))
- (process (zs-records s)
- (cons (zs-name s) dom)
- (zs-ttl s)))
- (let ((name (and dom
- (string-downcase
- (join-strings #\. (reverse dom))))))
- (dolist (zr top)
- (setf (zr-name zr) name)
- (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)
: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"))
+ &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
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.
- 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.
+ 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)
+ (LIST &key :name :type :data :ttl :make-ptr-p)
- 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))))
(with-parsed-body (body decls doc) body
- (with-gensyms (col tname ttype tttl tdata i)
+ (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)
+ (defun ,func (,prefix ,zname ,data ,ttl ,col)
,@doc
,@decls
- (declare (ignorable ,zname))
- (flet ((,list (&key ((:name ,tname) ,name)
- ((:type ,ttype) ,type)
- ((:data ,tdata) ,data)
- ((:ttl ,tttl) ,ttl))
- (collect (make-zone-record :name ,tname
- :type ,ttype
- :data ,tdata
- :ttl ,tttl)
- ,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))
+ (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))))
+ rec))))
(zone-process-records records
(zone-default-ttl zone)
#'parse-record))
(defzoneparse :a (name data rec)
":a IPADDR"
- (rec :data (parse-ipaddr data)))
+ (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"
(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
~mdw / zone / blobdiff