3 ;;; DNS zone generation
5 ;;; (c) 2005 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 2 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software Foundation,
22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;;--------------------------------------------------------------------------
29 #:mdw.base #:mdw.str #:collect #:safely
34 ;;;--------------------------------------------------------------------------
35 ;;; Various random utilities.
38 "Convert X to an integer in the most straightforward way."
41 (defun from-mixed-base (base val)
42 "BASE is a list of the ranges for the `digits' of a mixed-base
43 representation. Convert VAL, a list of digits, into an integer."
44 (do ((base base (cdr base))
45 (val (cdr val) (cdr val))
46 (a (car val) (+ (* a (car base)) (car val))))
47 ((or (null base) (null val)) a)))
49 (defun to-mixed-base (base val)
50 "BASE is a list of the ranges for the `digits' of a mixed-base
51 representation. Convert VAL, an integer, into a list of digits."
52 (let ((base (reverse base))
58 (multiple-value-bind (q r) (floor val (pop base))
62 (export 'timespec-seconds)
63 (defun timespec-seconds (ts)
64 "Convert a timespec TS to seconds.
66 A timespec may be a real count of seconds, or a list (COUNT UNIT). UNIT
67 may be any of a number of obvious time units."
69 ((realp ts) (floor ts))
71 (error "Unknown timespec format ~A" ts))
73 (timespec-seconds (car ts)))
74 (t (+ (to-integer (* (car ts)
75 (case (intern (string-upcase
76 (stringify (cadr ts)))
78 ((s sec secs second seconds) 1)
79 ((m min mins minute minutes) 60)
80 ((h hr hrs hour hours) #.(* 60 60))
81 ((d dy dys day days) #.(* 24 60 60))
82 ((w wk wks week weeks) #.(* 7 24 60 60))
83 ((y yr yrs year years) #.(* 365 24 60 60))
84 (t (error "Unknown time unit ~A"
86 (timespec-seconds (cddr ts))))))
88 (defun hash-table-keys (ht)
89 "Return a list of the keys in hashtable HT."
91 (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
93 (defun iso-date (&optional time &key datep timep (sep #\ ))
94 "Construct a textual date or time in ISO format.
96 The TIME is the universal time to convert, which defaults to now; DATEP is
97 whether to emit the date; TIMEP is whether to emit the time, and
98 SEP (default is space) is how to separate the two."
100 (sec min hr day mon yr dow dstp tz)
101 (decode-universal-time (if (or (null time) (eq time :now))
104 (declare (ignore dow dstp tz))
105 (with-output-to-string (s)
107 (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
111 (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
113 ;;;--------------------------------------------------------------------------
117 (defstruct (soa (:predicate soap))
118 "Start-of-authority record information."
128 (defstruct (mx (:predicate mxp))
129 "Mail-exchange record information."
134 (defstruct (zone (:predicate zonep))
141 ;;;--------------------------------------------------------------------------
142 ;;; Zone defaults. It is intended that scripts override these.
144 (export '*default-zone-source*)
145 (defvar *default-zone-source*
146 (let ((hn (gethostname)))
147 (and hn (concatenate 'string (canonify-hostname hn) ".")))
148 "The default zone source: the current host's name.")
150 (export '*default-zone-refresh*)
151 (defvar *default-zone-refresh* (* 24 60 60)
152 "Default zone refresh interval: one day.")
154 (export '*default-zone-admin*)
155 (defvar *default-zone-admin* nil
156 "Default zone administrator's email address.")
158 (export '*default-zone-retry*)
159 (defvar *default-zone-retry* (* 60 60)
160 "Default znoe retry interval: one hour.")
162 (export '*default-zone-expire*)
163 (defvar *default-zone-expire* (* 14 24 60 60)
164 "Default zone expiry time: two weeks.")
166 (export '*default-zone-min-ttl*)
167 (defvar *default-zone-min-ttl* (* 4 60 60)
168 "Default zone minimum TTL/negative TTL: four hours.")
170 (export '*default-zone-ttl*)
171 (defvar *default-zone-ttl* (* 8 60 60)
172 "Default zone TTL (for records without explicit TTLs): 8 hours.")
174 (export '*default-mx-priority*)
175 (defvar *default-mx-priority* 50
176 "Default MX priority.")
178 ;;;--------------------------------------------------------------------------
179 ;;; Zone variables and structures.
181 (defvar *zones* (make-hash-table :test #'equal)
182 "Map of known zones.")
185 (defun zone-find (name)
186 "Find a zone given its NAME."
187 (gethash (string-downcase (stringify name)) *zones*))
188 (defun (setf zone-find) (zone name)
189 "Make the zone NAME map to ZONE."
190 (setf (gethash (string-downcase (stringify name)) *zones*) zone))
192 (export 'zone-record)
193 (defstruct (zone-record (:conc-name zr-))
201 (export 'zone-subdomain)
202 (defstruct (zone-subdomain (:conc-name zs-))
205 Slightly weird. Used internally by `zone-process-records', and shouldn't
211 (export '*zone-output-path*)
212 (defvar *zone-output-path* nil
213 "Pathname defaults to merge into output files.
215 If this is nil then use the prevailing `*default-pathname-defaults*'.
216 This is not the same as capturing the `*default-pathname-defaults*' from
219 (export '*preferred-subnets*)
220 (defvar *preferred-subnets* nil
221 "Subnets to prefer when selecting defaults.")
223 ;;;--------------------------------------------------------------------------
224 ;;; Zone infrastructure.
226 (defun zone-file-name (zone type)
227 "Choose a file name for a given ZONE and TYPE."
228 (merge-pathnames (make-pathname :name (string-downcase zone)
229 :type (string-downcase type))
230 (or *zone-output-path* *default-pathname-defaults*)))
232 (export 'zone-preferred-subnet-p)
233 (defun zone-preferred-subnet-p (name)
234 "Answer whether NAME (a string or symbol) names a preferred subnet."
235 (member name *preferred-subnets* :test #'string-equal))
237 (export 'preferred-subnet-case)
238 (defmacro preferred-subnet-case (&body clauses)
239 "Execute a form based on which networks are considered preferred.
241 The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
242 whose SUBNETS (a list or single symbol, not evaluated) are listed in
243 `*preferred-subnets*'. If SUBNETS is the symbol `t' then the clause
246 ,@(mapcar (lambda (clause)
247 (let ((subnets (car clause)))
248 (cons (cond ((eq subnets t)
251 `(or ,@(mapcar (lambda (subnet)
252 `(zone-preferred-subnet-p
256 `(zone-preferred-subnet-p ',subnets)))
260 (defun zone-process-records (rec ttl func)
261 "Sort out the list of records in REC, calling FUNC for each one.
263 TTL is the default time-to-live for records which don't specify one.
265 REC is a list of records of the form
267 ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)
269 The various kinds of entries have the following meanings.
271 :ttl TTL Set the TTL for subsequent records (at this level of
274 TYPE DATA Define a record with a particular TYPE and DATA.
275 Record types are defined using `defzoneparse' and
276 the syntax of the data is idiosyncratic.
278 ((LABEL ...) . REC) Define records for labels within the zone. Any
279 records defined within REC will have their domains
280 prefixed by each of the LABELs. A singleton list
281 of labels may instead be written as a single
282 label. Note, therefore, that
284 (host (sub :a \"169.254.1.1\"))
286 defines a record for `host.sub' -- not `sub.host'.
288 If REC contains no top-level records, but it does define records for a
289 label listed in `*preferred-subnets*', then the records for the first such
290 label are also promoted to top-level.
292 The FUNC is called for each record encountered, represented as a
293 `zone-record' object. Zone parsers are not called: you get the record
294 types and data from the input form; see `zone-parse-records' if you want
297 (labels ((sift (rec ttl)
298 ;; Parse the record list REC into lists of `zone-record' and
299 ;; `zone-subdomain' objects, sorting out TTLs and so on.
300 ;; Returns them as two values.
302 (collecting (top sub)
308 (setf ttl (pop rec)))
310 (collect (make-zone-record :type r
315 (dolist (name (listify (car r)))
316 (collect (make-zone-subdomain :name name
321 (error "Unexpected record form ~A" (car r))))))))
323 (process (rec dom ttl)
324 ;; Recursirvely process the record list REC, with a list DOM of
325 ;; prefix labels, and a default TTL. Promote records for a
326 ;; preferred subnet to toplevel if there are no toplevel records
329 (multiple-value-bind (top sub) (sift rec ttl)
330 (if (and dom (null top) sub)
332 (or (find-if (lambda (s)
333 (some #'zone-preferred-subnet-p
334 (listify (zs-name s))))
338 (process (zs-records preferred)
340 (zs-ttl preferred))))
343 (join-strings #\. (reverse dom))))))
345 (setf (zr-name zr) name)
348 (process (zs-records s)
349 (cons (zs-name s) dom)
352 ;; Process the records we're given with no prefix.
353 (process rec nil ttl)))
355 (export 'zone-parse-host)
356 (defun zone-parse-host (f zname)
357 "Parse a host name F.
359 If F ends in a dot then it's considered absolute; otherwise it's relative
361 (setf f (stringify f))
362 (cond ((string= f "@") (stringify zname))
363 ((and (plusp (length f))
364 (char= (char f (1- (length f))) #\.))
365 (string-downcase (subseq f 0 (1- (length f)))))
366 (t (string-downcase (concatenate 'string f "."
367 (stringify zname))))))
368 (defun default-rev-zone (base bytes)
369 "Return the default reverse-zone name for the given BASE address and number
370 of fixed leading BYTES."
371 (join-strings #\. (collecting ()
372 (loop for i from (- 3 bytes) downto 0
373 do (collect (ipaddr-byte base i)))
374 (collect "in-addr.arpa"))))
376 (defun zone-name-from-net (net &optional bytes)
377 "Given a NET, and maybe the BYTES to use, convert to the appropriate
378 subdomain of in-addr.arpa."
379 (let ((ipn (net-get-as-ipnet net)))
380 (with-ipnet (net mask) ipn
382 (setf bytes (- 4 (ipnet-changeable-bytes mask))))
385 for i from (- 4 bytes) below 4
386 collect (logand #xff (ash net (* -8 i))))
387 (list "in-addr.arpa"))))))
389 (defun zone-net-from-name (name)
390 "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
391 (let* ((name (string-downcase (stringify name)))
393 (suffix ".in-addr.arpa")
394 (sufflen (length suffix))
397 (end (- len sufflen)))
398 (unless (and (> len sufflen)
399 (string= name suffix :start1 end))
400 (error "`~A' not in ~A." name suffix))
403 for dot = (position #\. name :start start :end end)
404 for byte = (parse-integer name
407 do (setf addr (logior addr (ash byte (* 8 n))))
410 do (error "Can't deduce network from ~A." name)
412 do (setf start (1+ dot)))
413 (setf addr (ash addr (* 8 (- 4 n))))
414 (make-ipnet addr (* 8 n))))
416 (defun zone-parse-net (net name)
417 "Given a NET, and the NAME of a domain to guess from if NET is null, return
418 the ipnet for the network."
420 (net-get-as-ipnet net)
421 (zone-net-from-name name)))
423 (defun zone-cidr-delg-default-name (ipn bytes)
424 "Given a delegated net IPN and the parent's number of changing BYTES,
425 return the default deletate zone prefix."
426 (with-ipnet (net mask) ipn
430 for i from (1- bytes) downto 0
431 until (zerop (logand mask (ash #xff (* 8 i))))
432 collect (logand #xff (ash net (* -8 i))))))))
434 ;;;--------------------------------------------------------------------------
435 ;;; Serial numbering.
437 (export 'make-zone-serial)
438 (defun make-zone-serial (name)
439 "Given a zone NAME, come up with a new serial number.
441 This will (very carefully) update a file ZONE.serial in the current
443 (let* ((file (zone-file-name name :serial))
444 (last (with-open-file (in file
446 :if-does-not-exist nil)
449 (now (multiple-value-bind
450 (sec min hr dy mon yr dow dstp tz)
452 (declare (ignore sec min hr dow dstp tz))
454 (seq (cond ((not (equal now (cdr last))) 0)
455 ((< (car last) 99) (1+ (car last)))
456 (t (error "Run out of sequence numbers for ~A" name)))))
457 (safely-writing (out file)
459 ";; Serial number file for zone ~A~%~
460 ;; (LAST-SEQ DAY MONTH YEAR)~%~
464 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
466 ;;;--------------------------------------------------------------------------
467 ;;; Zone form parsing.
469 (defun zone-parse-head (head)
470 "Parse the HEAD of a zone form.
474 (NAME &key :source :admin :refresh :retry
475 :expire :min-ttl :ttl :serial)
477 though a singleton NAME needn't be a list. Returns the default TTL and an
478 soa structure representing the zone head."
482 (source *default-zone-source*)
483 (admin (or *default-zone-admin*
484 (format nil "hostmaster@~A" zname)))
485 (refresh *default-zone-refresh*)
486 (retry *default-zone-retry*)
487 (expire *default-zone-expire*)
488 (min-ttl *default-zone-min-ttl*)
490 (serial (make-zone-serial zname)))
493 (timespec-seconds ttl)
494 (make-soa :admin admin
495 :source (zone-parse-host source zname)
496 :refresh (timespec-seconds refresh)
497 :retry (timespec-seconds retry)
498 :expire (timespec-seconds expire)
499 :min-ttl (timespec-seconds min-ttl)
502 (export 'zone-make-name)
503 (defun zone-make-name (prefix zone-name)
504 "Compute a full domain name from a PREFIX and a ZONE-NAME.
506 If the PREFIX ends with `.' then it's absolute already; otherwise, append
507 the ZONE-NAME, separated with a `.'. If PREFIX is nil, or `@', then
508 return the ZONE-NAME only."
509 (if (or (not prefix) (string= prefix "@"))
511 (let ((len (length prefix)))
512 (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
513 (join-strings #\. (list prefix zone-name))
516 (export 'defzoneparse)
517 (defmacro defzoneparse (types (name data list
518 &key (prefix (gensym "PREFIX"))
519 (zname (gensym "ZNAME"))
520 (ttl (gensym "TTL")))
522 "Define a new zone record type.
524 The arguments are as follows:
526 TYPES A singleton type symbol, or a list of aliases.
528 NAME The name of the record to be added.
530 DATA The content of the record to be added (a single object,
533 LIST A function to add a record to the zone. See below.
535 PREFIX The prefix tag used in the original form.
537 ZNAME The name of the zone being constructed.
539 TTL The TTL for this record.
541 You get to choose your own names for these. ZNAME, PREFIX and TTL are
542 optional: you don't have to accept them if you're not interested.
544 The LIST argument names a function to be bound in the body to add a new
545 low-level record to the zone. It has the prototype
547 (LIST &key :name :type :data :ttl :make-ptr-p)
549 These (except MAKE-PTR-P, which defaults to nil) default to the above
550 arguments (even if you didn't accept the arguments)."
551 (setf types (listify types))
552 (let* ((type (car types))
553 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
554 (with-parsed-body (body decls doc) body
555 (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
558 (setf (get ,i 'zone-parse) ',func))
559 (defun ,func (,prefix ,zname ,data ,ttl ,col)
562 (let ((,name (zone-make-name ,prefix ,zname)))
563 (flet ((,list (&key ((:name ,tname) ,name)
564 ((:type ,ttype) ,type)
565 ((:data ,tdata) ,data)
567 ((:make-ptr-p ,tmakeptrp) nil))
568 #+cmu (declare (optimize ext:inhibit-warnings))
569 (collect (make-zone-record :name ,tname
573 :make-ptr-p ,tmakeptrp)
578 (export 'zone-parse-records)
579 (defun zone-parse-records (zname ttl records)
580 "Parse a sequence of RECORDS and return a list of raw records.
582 The records are parsed relative to the zone name ZNAME, and using the
585 (flet ((parse-record (zr)
586 (let ((func (or (get (zr-type zr) 'zone-parse)
587 (error "No parser for record ~A."
589 (name (and (zr-name zr) (stringify (zr-name zr)))))
590 (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
591 (zone-process-records records ttl #'parse-record))))
594 (defun zone-parse (zf)
597 The syntax of a zone form is as follows:
600 ZONE-HEAD ZONE-RECORD*
603 ((NAME*) ZONE-RECORD*)
605 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
606 (make-zone :name zname
609 :records (zone-parse-records zname ttl (cdr zf)))))
611 (export 'zone-create)
612 (defun zone-create (zf)
613 "Zone construction function. Given a zone form ZF, construct the zone and
614 add it to the table."
615 (let* ((zone (zone-parse zf))
616 (name (zone-name zone)))
617 (setf (zone-find name) zone)
621 (defmacro defzone (soa &rest zf)
622 "Zone definition macro."
623 `(zone-create '(,soa ,@zf)))
626 (defmacro defrevzone (head &rest zf)
627 "Define a reverse zone, with the correct name."
632 (when (and soa-args (integerp (car soa-args)))
633 (setf bytes (pop soa-args)))
634 `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
636 ;;;--------------------------------------------------------------------------
637 ;;; Zone record parsers.
639 (defzoneparse :a (name data rec)
641 (rec :data (parse-ipaddr data) :make-ptr-p t))
643 (defzoneparse :svc (name data rec)
645 (rec :type :a :data (parse-ipaddr data)))
647 (defzoneparse :ptr (name data rec :zname zname)
649 (rec :data (zone-parse-host data zname)))
651 (defzoneparse :cname (name data rec :zname zname)
653 (rec :data (zone-parse-host data zname)))
655 (defzoneparse :txt (name data rec)
659 (export '*dkim-pathname-defaults*)
660 (defvar *dkim-pathname-defaults*
661 (make-pathname :directory '(:relative "keys")
664 (defzoneparse :dkim (name data rec)
665 ":dkim (KEYFILE {:TAG VALUE}*)"
666 (destructuring-bind (file &rest plist) (listify data)
667 (let ((things nil) (out nil))
670 (push (get-output-stream-string out) things)
673 (let ((len (length text)))
674 (when (and out (> (+ (file-position out)
680 (unless out (setf out (make-string-output-stream)))
681 (write-string text out))
686 (push (subseq text i (min j len)) things))))))))
687 (do ((p plist (cddr p)))
689 (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
690 (emit (with-output-to-string (out)
691 (write-string "p=" out)
694 (in (merge-pathnames file *dkim-pathname-defaults*))
696 (when (string= (read-line in)
697 "-----BEGIN PUBLIC KEY-----")
700 (let ((line (read-line in)))
701 (if (string= line "-----END PUBLIC KEY-----")
703 (write-string line out)))))))))
705 :data (nreverse things)))))
707 (eval-when (:load-toplevel :execute)
708 (dolist (item '((sshfp-algorithm rsa 1)
709 (sshfp-algorithm dsa 2)
710 (sshfp-algorithm ecdsa 3)
712 (sshfp-type sha-256 2)))
713 (destructuring-bind (prop sym val) item
714 (setf (get sym prop) val)
717 (export '*sshfp-pathname-defaults*)
718 (defvar *sshfp-pathname-defaults*
719 (make-pathname :directory '(:relative "keys")
722 (defzoneparse :sshfp (name data rec)
723 ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
725 (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
726 (loop (let ((line (read-line in nil)))
727 (unless line (return))
728 (let ((words (str-split-words line)))
730 (when (string= (car words) "IN") (pop words))
731 (unless (and (string= (car words) "SSHFP")
732 (= (length words) 4))
733 (error "Invalid SSHFP record."))
735 (destructuring-bind (alg type fpr) words
736 (rec :data (list (parse-integer alg)
739 (flet ((lookup (what prop)
742 (symbol (or (get what prop)
743 (error "~S is not a known ~A" what prop))))))
744 (dolist (item (listify data))
745 (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
747 (rec :data (list (lookup alg 'sshfp-algorithm)
748 (lookup type 'sshfp-type)
751 (defzoneparse :mx (name data rec :zname zname)
752 ":mx ((HOST :prio INT :ip IPADDR)*)"
753 (dolist (mx (listify data))
755 (mxname &key (prio *default-mx-priority*) ip)
757 (let ((host (zone-parse-host mxname zname)))
758 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
759 (rec :data (cons host prio))))))
761 (defzoneparse :ns (name data rec :zname zname)
762 ":ns ((HOST :ip IPADDR)*)"
763 (dolist (ns (listify data))
767 (let ((host (zone-parse-host nsname zname)))
768 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
771 (defzoneparse :alias (name data rec :zname zname)
773 (dolist (a (listify data))
774 (rec :name (zone-parse-host a zname)
778 (defzoneparse :srv (name data rec :zname zname)
779 ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
781 (destructuring-bind (servopts &rest providers) srv
783 (service &key ((:port default-port)) (protocol :tcp))
786 (let ((serv (serv-by-name service protocol)))
787 (setf default-port (and serv (serv-port serv)))))
788 (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
789 (dolist (prov providers)
794 (prio *default-mx-priority*)
798 (let ((host (zone-parse-host srvname zname)))
799 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
801 :data (list prio weight port host))))))))))
803 (defzoneparse :net (name data rec)
805 (dolist (net (listify data))
806 (let ((n (net-get-as-ipnet net)))
807 (rec :name (zone-parse-host "net" name)
810 (rec :name (zone-parse-host "mask" name)
812 :data (ipnet-mask n))
813 (rec :name (zone-parse-host "bcast" name)
815 :data (ipnet-broadcast n)))))
817 (defzoneparse (:rev :reverse) (name data rec)
818 ":reverse ((NET :bytes BYTES) ZONE*)
820 Add a reverse record each host in the ZONEs (or all zones) that lies
821 within NET. The BYTES give the number of prefix labels generated; this
822 defaults to the smallest number of bytes needed to enumerate the net."
823 (setf data (listify data))
824 (destructuring-bind (net &key bytes) (listify (car data))
825 (setf net (zone-parse-net net name))
827 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
828 (let ((seen (make-hash-table :test #'equal)))
829 (dolist (z (or (cdr data)
830 (hash-table-keys *zones*)))
831 (dolist (zr (zone-records (zone-find z)))
832 (when (and (eq (zr-type zr) :a)
834 (ipaddr-networkp (zr-data zr) net))
835 (let ((name (string-downcase
840 (collect (logand #xff (ash (zr-data zr)
843 (unless (gethash name seen)
844 (rec :name name :type :ptr
845 :ttl (zr-ttl zr) :data (zr-name zr))
846 (setf (gethash name seen) t)))))))))
848 (defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
849 ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*)
851 Insert CNAME records for delegating a portion of the reverse-lookup
852 namespace which doesn't align with an octet boundary.
854 The NET specifies the origin network, in which the reverse records
855 naturally lie. The BYTES are the number of labels to supply for each
856 address; the default is the smallest number which suffices to enumerate
857 the entire NET. The TARGET-NETs are subnets of NET which are to be
858 delegated. The TARGET-ZONEs are the zones to which we are delegating
859 authority for the reverse records: the default is to append labels for those
860 octets of the subnet base address which are not the same in all address in
862 (setf data (listify data))
863 (destructuring-bind (net &key bytes) (listify (car data))
864 (setf net (zone-parse-net net name))
866 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
867 (dolist (map (or (cdr data) (list (list net))))
868 (destructuring-bind (tnets &optional tdom) (listify map)
869 (dolist (tnet (listify tnets))
870 (setf tnet (zone-parse-net tnet name))
871 (unless (ipnet-subnetp net tnet)
872 (error "~A is not a subnet of ~A."
876 (with-ipnet (net mask) tnet
880 (append (reverse (loop
881 for i from (1- bytes) downto 0
882 until (zerop (logand mask
885 collect (ldb (byte 8 (* i 8)) net)))
887 (setf tdom (string-downcase (stringify tdom)))
888 (dotimes (i (ipnet-hosts tnet))
890 (let* ((addr (ipnet-host tnet i))
891 (tail (join-strings #\.
893 for i from 0 below bytes
896 (ash addr (* 8 i)))))))
897 (rec :name (format nil "~A.~A" tail name)
899 :data (format nil "~A.~A" tail tdom))))))))))
901 ;;;--------------------------------------------------------------------------
902 ;;; Zone file output.
905 (defgeneric zone-write (format zone stream)
906 (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
908 (defvar *writing-zone* nil
909 "The zone currently being written.")
911 (defvar *zone-output-stream* nil
912 "Stream to write zone data on.")
914 (defmethod zone-write :around (format zone stream)
915 (declare (ignore format))
916 (let ((*writing-zone* zone)
917 (*zone-output-stream* stream))
921 (defun zone-save (zones &key (format :bind))
922 "Write the named ZONES to files. If no zones are given, write all the
925 (setf zones (hash-table-keys *zones*)))
928 (let ((zz (zone-find z)))
930 (error "Unknown zone `~A'." z))
931 (let ((stream (safely-open-output-stream safe
932 (zone-file-name z :zone))))
933 (zone-write format zz stream))))))
935 ;;;--------------------------------------------------------------------------
936 ;;; Bind format output.
938 (export 'bind-hostname)
939 (defun bind-hostname (hostname)
942 (let* ((h (string-downcase (stringify hostname)))
944 (r (string-downcase (zone-name *writing-zone*)))
946 (cond ((string= r h) "@")
948 (char= (char h (- hl rl 1)) #\.)
949 (string= h r :start1 (- hl rl)))
950 (subseq h 0 (- hl rl 1)))
951 (t (concatenate 'string h "."))))))
953 (defmethod zone-write ((format (eql :bind)) zone stream)
955 ;;; Zone file `~(~A~)'
961 (iso-date :now :datep t :timep t)
962 (zone-default-ttl zone))
963 (let* ((soa (zone-soa zone))
964 (admin (let* ((name (soa-admin soa))
965 (at (position #\@ name))
966 (copy (format nil "~(~A~)." name)))
968 (setf (char copy at) #\.))
971 ~A~30TIN SOA~40T~A ~A (
973 ~45T~10D~60T ;refresh
976 ~45T~10D )~60T ;min-ttl~2%"
977 (bind-hostname (zone-name zone))
978 (bind-hostname (soa-source soa))
985 (dolist (zr (zone-records zone))
986 (bind-record (zr-type zr) zr)))
988 (export 'bind-record)
989 (defgeneric bind-record (type zr))
991 (export 'bind-format-record)
992 (defun bind-format-record (name ttl type format args)
993 (format *zone-output-stream*
994 "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
996 (and (/= ttl (zone-default-ttl *writing-zone*))
998 (string-upcase (symbol-name type))
1001 (defmethod bind-record (type zr)
1002 (destructuring-bind (format &rest args)
1003 (bind-record-format-args type (zr-data zr))
1004 (bind-format-record (zr-name zr)
1006 (bind-record-type type)
1009 (export 'bind-record-type)
1010 (defgeneric bind-record-type (type)
1011 (:method (type) type))
1013 (export 'bind-record-format-args)
1014 (defgeneric bind-record-format-args (type data)
1015 (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
1016 (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
1017 (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
1018 (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
1019 (:method ((type (eql :mx)) data)
1020 (list "~2D ~A" (cdr data) (bind-hostname (car data))))
1021 (:method ((type (eql :srv)) data)
1022 (destructuring-bind (prio weight port host) data
1023 (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
1024 (:method ((type (eql :sshfp)) data)
1025 (cons "~2D ~2D ~A" data))
1026 (:method ((type (eql :txt)) data)
1027 (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
1028 (mapcar #'stringify (listify data)))))
1030 ;;;----- That's all, folks --------------------------------------------------