;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; DNS zone generation
;;;
;;; (c) 2005 Straylight/Edgeware
;;; Packaging.
(defpackage #:zone
- (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net)
- (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain
- #:*default-zone-source* #:*default-zone-refresh*
- #:*default-zone-retry* #:*default-zone-expire*
- #:*default-zone-min-ttl* #:*default-zone-ttl*
- #:*default-mx-priority* #:*default-zone-admin*
- #:*zone-output-path*
- #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
- #:defrevzone #:zone-save #:zone-make-name
- #:defzoneparse #:zone-parse-host
- #:timespec-seconds #:make-zone-serial))
+ (:use #:common-lisp
+ #:mdw.base #:mdw.str #:collect #:safely
+ #:net #:services))
(in-package #:zone)
(push r a)
(setf val q)))))
+(export 'timespec-seconds)
(defun timespec-seconds (ts)
- "Convert a timespec TS to seconds. A timespec may be a real count of
- seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious
- time units."
+ "Convert a timespec TS to seconds.
+
+ A timespec may be a real count of seconds, or a list (COUNT UNIT): UNIT
+ may be any of a number of obvious time units."
(cond ((null ts) 0)
((realp ts) (floor ts))
((atom ts)
(maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
(defun iso-date (&optional time &key datep timep (sep #\ ))
- "Construct a textual date or time in ISO format. The TIME is the universal
- time to convert, which defaults to now; DATEP is whether to emit the date;
- TIMEP is whether to emit the time, and SEP (default is space) is how to
- separate the two."
+ "Construct a textual date or time in ISO format.
+
+ The TIME is the universal time to convert, which defaults to now; DATEP is
+ whether to emit the date; TIMEP is whether to emit the time, and
+ SEP (default is space) is how to separate the two."
(multiple-value-bind
(sec min hr day mon yr dow dstp tz)
(decode-universal-time (if (or (null time) (eq time :now))
;;;--------------------------------------------------------------------------
;;; Zone types.
+(export 'soa)
(defstruct (soa (:predicate soap))
"Start-of-authority record information."
source
min-ttl
serial)
+(export 'mx)
(defstruct (mx (:predicate mxp))
"Mail-exchange record information."
priority
domain)
+(export 'zone)
(defstruct (zone (:predicate zonep))
"Zone information."
soa
;;;--------------------------------------------------------------------------
;;; Zone defaults. It is intended that scripts override these.
-#+ecl
-(cffi:defcfun gethostname :int
- (name :pointer)
- (len :uint))
-
+(export '*default-zone-source*)
(defvar *default-zone-source*
- (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))))))
+ (let ((hn (gethostname)))
(and hn (concatenate 'string (canonify-hostname hn) ".")))
"The default zone source: the current host's name.")
+(export '*default-zone-refresh*)
(defvar *default-zone-refresh* (* 24 60 60)
"Default zone refresh interval: one day.")
+(export '*default-zone-admin*)
(defvar *default-zone-admin* nil
"Default zone administrator's email address.")
+(export '*default-zone-retry*)
(defvar *default-zone-retry* (* 60 60)
"Default znoe retry interval: one hour.")
+(export '*default-zone-expire*)
(defvar *default-zone-expire* (* 14 24 60 60)
"Default zone expiry time: two weeks.")
+(export '*default-zone-min-ttl*)
(defvar *default-zone-min-ttl* (* 4 60 60)
"Default zone minimum TTL/negative TTL: four hours.")
+(export '*default-zone-ttl*)
(defvar *default-zone-ttl* (* 8 60 60)
"Default zone TTL (for records without explicit TTLs): 8 hours.")
+(export '*default-mx-priority*)
(defvar *default-mx-priority* 50
"Default MX priority.")
(defvar *zones* (make-hash-table :test #'equal)
"Map of known zones.")
+(export 'zone-find)
(defun zone-find (name)
"Find a zone given its NAME."
(gethash (string-downcase (stringify name)) *zones*))
-
(defun (setf zone-find) (zone name)
"Make the zone NAME map to ZONE."
(setf (gethash (string-downcase (stringify name)) *zones*) zone))
+(export 'zone-record)
(defstruct (zone-record (:conc-name zr-))
"A zone record."
(name '<unnamed>)
(make-ptr-p nil)
data)
+(export 'zone-subdomain)
(defstruct (zone-subdomain (:conc-name zs-))
"A subdomain. Slightly weird. Used internally by zone-process-records
below, and shouldn't escape."
ttl
records)
-(defvar *zone-output-path* *default-pathname-defaults*
- "Pathname defaults to merge into output files.")
+(export '*zone-output-path*)
+(defvar *zone-output-path* nil
+ "Pathname defaults to merge into output files.
+
+ If this is nil then use the prevailing `*default-pathname-defaults*'.
+ This is not the same as capturing the `*default-pathname-defaults*' from
+ load time.")
+
+(export '*preferred-subnets*)
+(defvar *preferred-subnets* nil
+ "Subnets to prefer when selecting defaults.")
;;;--------------------------------------------------------------------------
;;; Zone infrastructure.
"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*))
+ (or *zone-output-path* *default-pathname-defaults*)))
+
+(export 'zone-preferred-subnet-p)
+(defun zone-preferred-subnet-p (name)
+ "Answer whether NAME (a string or symbol) names a preferred subnet."
+ (member name *preferred-subnets* :test #'string-equal))
+
+(export 'preferred-subnet-case)
+(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."
+ "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.
+
+ The syntax is a little fiddly to describe. It operates relative to a
+ subzone name NAME.
+
+ ZONE-RECORD: RR | TTL | SUBZONE
+ The body of a zone form is a sequence of these.
+
+ TTL: :ttl INTEGER
+ Sets the TTL for subsequent RRs in this zone or subzone.
+
+ RR: SYMBOL DATA
+ Adds a record for the current NAME; the SYMBOL denotes the record
+ type, and the DATA depends on the type.
+
+ SUBZONE: (LABELS ZONE-RECORD*)
+ Defines a subzone. The LABELS is either a list of labels, or a
+ singleton label. For each LABEL, evaluate the ZONE-RECORDs relative
+ to LABEL.NAME. The special LABEL `@' is a no-op."
(labels ((sift (rec ttl)
(collecting (top sub)
(loop
(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
+ (or (find-if (lambda (s)
+ (some #'zone-preferred-subnet-p
+ (listify (zs-name s))))
+ sub)
+ (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))))))
(process rec nil ttl)))
+(export 'zone-parse-host)
(defun zone-parse-host (f zname)
"Parse a host name F: if F ends in a dot then it's considered absolute;
otherwise it's relative to ZNAME."
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.
+(export 'make-zone-serial)
(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."
+ "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
(safely-writing (out file)
(format out
";; Serial number file for zone ~A~%~
- ;; (LAST-SEQ DAY MONTH YEAR)~%~
- ~S~%"
+ ;; (LAST-SEQ DAY MONTH YEAR)~%~
+ ~S~%"
name
(cons seq now)))
(from-mixed-base '(100 100 100) (reverse (cons seq now)))))
;;; Zone form parsing.
(defun zone-parse-head (head)
- "Parse the HEAD of a zone form. This has the form
+ "Parse the HEAD of a zone form.
+
+ This has the form
(NAME &key :source :admin :refresh :retry
- :expire :min-ttl :ttl :serial)
+ :expire :min-ttl :ttl :serial)
though a singleton NAME needn't be a list. Returns the default TTL and an
soa structure representing the zone head."
:min-ttl (timespec-seconds min-ttl)
:serial serial))))
+(export 'zone-make-name)
(defun zone-make-name (prefix zone-name)
(if (or (not prefix) (string= prefix "@"))
zone-name
(join-strings #\. (list prefix zone-name))
prefix))))
+(export 'defzoneparse)
(defmacro defzoneparse (types (name data list
&key (prefix (gensym "PREFIX"))
- (zname (gensym "ZNAME"))
- (ttl (gensym "TTL")))
+ (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:
+ "Define a new zone record type.
+
+ The TYPES may be a list of synonyms. The other arguments are as follows:
NAME The name of the record to be added.
((: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
',type)))))
(defun zone-parse-records (zone records)
+ "Parse the body of a zone form.
+
+ ZONE is the zone object; RECORDS is the body of the form."
(let ((zname (zone-name zone)))
(with-collection (rec)
(flet ((parse-record (zr)
#'parse-record))
(setf (zone-records zone) (nconc (zone-records zone) rec)))))
+(export 'zone-parse)
(defun zone-parse (zf)
- "Parse a ZONE form. The syntax of a zone form is as follows:
+ "Parse a ZONE form.
+
+ The syntax of a zone form is as follows:
ZONE-FORM:
ZONE-HEAD ZONE-RECORD*
(zone-parse-records zone (cdr zf))
zone)))
+(export 'zone-create)
(defun zone-create (zf)
"Zone construction function. Given a zone form ZF, construct the zone and
add it to the table."
(setf (zone-find name) zone)
name))
+(export 'defzone)
(defmacro defzone (soa &rest zf)
"Zone definition macro."
`(zone-create '(,soa ,@zf)))
+(export 'defrevzone)
(defmacro defrevzone (head &rest zf)
"Define a reverse zone, with the correct name."
(destructuring-bind
":cname HOST"
(rec :data (zone-parse-host data zname)))
+(defzoneparse :txt (name data rec)
+ ":txt TEXT"
+ (rec :data data))
+
+(defzoneparse :dkim (name data rec)
+ ":dkim (KEYFILE {:TAG VALUE}*)"
+ (destructuring-bind (file &rest plist) (listify data)
+ (let ((things nil) (out nil))
+ (labels ((flush ()
+ (when out
+ (push (get-output-stream-string out) things)
+ (setf out nil)))
+ (emit (text)
+ (let ((len (length text)))
+ (when (and out (> (+ (file-position out)
+ (length text))
+ 64))
+ (flush))
+ (when (plusp len)
+ (cond ((< len 64)
+ (unless out (setf out (make-string-output-stream)))
+ (write-string text out))
+ (t
+ (do ((i 0 j)
+ (j 64 (+ j 64)))
+ ((>= i len))
+ (push (subseq text i (min j len)) things))))))))
+ (do ((p plist (cddr p)))
+ ((endp p))
+ (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
+ (emit (with-output-to-string (out)
+ (write-string "p=" out)
+ (when file
+ (with-open-file (in file :direction :input)
+ (loop
+ (when (string= (read-line in)
+ "-----BEGIN PUBLIC KEY-----")
+ (return)))
+ (loop
+ (let ((line (read-line in)))
+ (if (string= line "-----END PUBLIC KEY-----")
+ (return)
+ (write-string line out)))))))))
+ (rec :type :txt
+ :data (nreverse things)))))
+
+(eval-when (:load-toplevel :execute)
+ (dolist (item '((sshfp-algorithm rsa 1)
+ (sshfp-algorithm dsa 2)
+ (sshfp-algorithm ecdsa 3)
+ (sshfp-type sha-1 1)
+ (sshfp-type sha-256 2)))
+ (destructuring-bind (prop sym val) item
+ (setf (get sym prop) val)
+ (export sym))))
+
+(defzoneparse :sshfp (name data rec)
+ ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
+ (if (stringp data)
+ (with-open-file (in data)
+ (loop (let ((line (read-line in nil)))
+ (unless line (return))
+ (let ((words (str-split-words line)))
+ (pop words)
+ (when (string= (car words) "IN") (pop words))
+ (unless (and (string= (car words) "SSHFP")
+ (= (length words) 4))
+ (error "Invalid SSHFP record."))
+ (pop words)
+ (destructuring-bind (alg type fpr) words
+ (rec :data (list (parse-integer alg)
+ (parse-integer type)
+ fpr)))))))
+ (flet ((lookup (what prop)
+ (etypecase what
+ (fixnum what)
+ (symbol (or (get what prop)
+ (error "~S is not a known ~A" what prop))))))
+ (dolist (item (listify data))
+ (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
+ (listify item)
+ (rec :data (list (lookup alg 'sshfp-algorithm)
+ (lookup type 'sshfp-type)
+ fpr)))))))
+
(defzoneparse :mx (name data rec :zname zname)
":mx ((HOST :prio INT :ip IPADDR)*)"
(dolist (mx (listify data))
:type :cname
:data name)))
+(defzoneparse :srv (name data rec :zname zname)
+ ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
+ (dolist (srv data)
+ (destructuring-bind (servopts &rest providers) srv
+ (destructuring-bind
+ (service &key ((:port default-port)) (protocol :tcp))
+ (listify servopts)
+ (unless default-port
+ (let ((serv (serv-by-name service protocol)))
+ (setf default-port (and serv (serv-port serv)))))
+ (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
+ (dolist (prov providers)
+ (destructuring-bind
+ (srvname
+ &key
+ (port default-port)
+ (prio *default-mx-priority*)
+ (weight 0)
+ ip)
+ (listify prov)
+ (let ((host (zone-parse-host srvname zname)))
+ (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
+ (rec :name rname
+ :data (list prio weight port host))))))))))
+
(defzoneparse :net (name data rec)
":net (NETWORK*)"
(dolist (net (listify data))
(rec :name (zone-parse-host "mask" name)
:type :a
:data (ipnet-mask n))
- (rec :name (zone-parse-host "broadcast" name)
+ (rec :name (zone-parse-host "bcast" name)
:type :a
:data (ipnet-broadcast n)))))
(defzoneparse (:rev :reverse) (name data rec)
- ":reverse ((NET :bytes BYTES) ZONE*)"
+ ":reverse ((NET :bytes BYTES) ZONE*)
+
+ Add a reverse record each host in the ZONEs (or all zones) that lies
+ within NET. The BYTES give the number of prefix labels generated; this
+ defaults to the smallest number of bytes needed to enumerate the net."
(setf data (listify data))
- (destructuring-bind
- (net &key bytes)
- (listify (car data))
+ (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))))
: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])*)"
- (destructuring-bind
- (net &key bytes)
- (listify (car data))
+(defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
+ ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*)
+
+ Insert CNAME records for delegating a portion of the reverse-lookup
+ namespace which doesn't align with an octet boundary.
+
+ The NET specifies the origin network, in which the reverse records
+ naturally lie. The BYTES are the number of labels to supply for each
+ address; the default is the smallest number which suffices to enumerate
+ the entire NET. The TARGET-NETs are subnets of NET which are to be
+ delegated. The TARGET-ZONEs are the zones to which we are delegating
+ authority for the reverse records: the default is to append labels for those
+ octets of the subnet base address which are not the same in all address in
+ the subnet."
+ (setf data (listify data))
+ (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
- (with-ipnet (net mask) tnet
- (setf tdom
- (join-strings
- #\.
- (append (reverse (loop
+ (dolist (map (or (cdr data) (list (list net))))
+ (destructuring-bind (tnets &optional tdom) (listify map)
+ (dolist (tnet (listify tnets))
+ (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
+ (with-ipnet (net mask) tnet
+ (setf tdom
+ (join-strings
+ #\.
+ (append (reverse (loop
for i from (1- bytes) downto 0
until (zerop (logand mask
(ash #xff
(* 8 i))))
- collect (logand #xff
- (ash net (* -8 i)))))
- (list 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
+ collect (ldb (byte 8 (* i 8)) net)))
+ (list name))))))
+ (setf tdom (string-downcase (stringify tdom)))
+ (dotimes (i (ipnet-hosts tnet))
+ (unless (zerop i)
+ (let* ((addr (ipnet-host tnet i))
+ (tail (join-strings #\.
+ (loop
+ for i from 0 below bytes
+ collect
(logand #xff
(ash addr (* 8 i)))))))
- (rec :name (format nil "~A.~A" tail name)
- :type :cname
- :data (format nil "~A.~A" tail tdom))))))))
+ (rec :name (format nil "~A.~A" tail name)
+ :type :cname
+ :data (format nil "~A.~A" tail 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 "~
+(export 'zone-write)
+(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)
+ (declare (ignore format))
+ (let ((*writing-zone* zone)
+ (*zone-output-stream* stream))
+ (call-next-method)))
+
+(export 'zone-save)
+(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.
+
+(export 'bind-hostname)
+(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)
(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))
- (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)))
+
+(export 'bind-record)
+(defgeneric bind-record (type zr))
+
+(export 'bind-format-record)
+(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)))
+
+(export 'bind-record-type)
+(defgeneric bind-record-type (type)
+ (:method (type) type))
+
+(export 'bind-record-format-args)
+(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 :srv)) data)
+ (destructuring-bind (prio weight port host) data
+ (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
+ (:method ((type (eql :sshfp)) data)
+ (cons "~2D ~2D ~A" data))
+ (:method ((type (eql :txt)) data)
+ (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
+ (mapcar #'stringify (listify data)))))
;;;----- That's all, folks --------------------------------------------------
~mdw / zone / blobdiff