5 ;;; DNS zone generation
7 ;;; (c) 2005 Straylight/Edgeware
10 ;;;----- Licensing notice ---------------------------------------------------
12 ;;; This program is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; This program is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with this program; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
26 ;;;--------------------------------------------------------------------------
30 (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net)
31 (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain
32 #:*default-zone-source* #:*default-zone-refresh*
33 #:*default-zone-retry* #:*default-zone-expire*
34 #:*default-zone-min-ttl* #:*default-zone-ttl*
35 #:*default-mx-priority* #:*default-zone-admin*
36 #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
37 #:defrevzone #:zone-save
38 #:defzoneparse #:zone-parse-host
39 #:timespec-seconds #:make-zone-serial))
43 ;;;--------------------------------------------------------------------------
44 ;;; Various random utilities.
47 "Convert X to an integer in the most straightforward way."
50 (defun from-mixed-base (base val)
51 "BASE is a list of the ranges for the `digits' of a mixed-base
52 representation. Convert VAL, a list of digits, into an integer."
53 (do ((base base (cdr base))
54 (val (cdr val) (cdr val))
55 (a (car val) (+ (* a (car base)) (car val))))
56 ((or (null base) (null val)) a)))
58 (defun to-mixed-base (base val)
59 "BASE is a list of the ranges for the `digits' of a mixed-base
60 representation. Convert VAL, an integer, into a list of digits."
61 (let ((base (reverse base))
67 (multiple-value-bind (q r) (floor val (pop base))
71 (defun timespec-seconds (ts)
72 "Convert a timespec TS to seconds. A timespec may be a real count of
73 seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious time
76 ((realp ts) (floor ts))
78 (error "Unknown timespec format ~A" ts))
80 (timespec-seconds (car ts)))
81 (t (+ (to-integer (* (car ts)
82 (case (intern (string-upcase
83 (stringify (cadr ts)))
85 ((s sec secs second seconds) 1)
86 ((m min mins minute minutes) 60)
87 ((h hr hrs hour hours) #.(* 60 60))
88 ((d dy dys day days) #.(* 24 60 60))
89 ((w wk wks week weeks) #.(* 7 24 60 60))
90 ((y yr yrs year years) #.(* 365 24 60 60))
91 (t (error "Unknown time unit ~A"
93 (timespec-seconds (cddr ts))))))
95 (defun hash-table-keys (ht)
96 "Return a list of the keys in hashtable HT."
98 (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
100 (defun iso-date (&optional time &key datep timep (sep #\ ))
101 "Construct a textual date or time in ISO format. The TIME is the universal
102 time to convert, which defaults to now; DATEP is whether to emit the date;
103 TIMEP is whether to emit the time, and SEP (default is space) is how to
106 (sec min hr day mon yr dow dstp tz)
107 (decode-universal-time (if (or (null time) (eq time :now))
110 (declare (ignore dow dstp tz))
111 (with-output-to-string (s)
113 (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
117 (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
119 ;;;--------------------------------------------------------------------------
122 (defstruct (soa (:predicate soap))
123 "Start-of-authority record information."
132 (defstruct (mx (:predicate mxp))
133 "Mail-exchange record information."
137 (defstruct (zone (:predicate zonep))
144 ;;;--------------------------------------------------------------------------
145 ;;; Zone defaults. It is intended that scripts override these.
147 (defvar *default-zone-source*
148 (let ((hn (unix:unix-gethostname)))
149 (and hn (concatenate 'string (canonify-hostname hn) ".")))
150 "The default zone source: the current host's name.")
152 (defvar *default-zone-refresh* (* 24 60 60)
153 "Default zone refresh interval: one day.")
155 (defvar *default-zone-admin* nil
156 "Default zone administrator's email address.")
158 (defvar *default-zone-retry* (* 60 60)
159 "Default znoe retry interval: one hour.")
161 (defvar *default-zone-expire* (* 14 24 60 60)
162 "Default zone expiry time: two weeks.")
164 (defvar *default-zone-min-ttl* (* 4 60 60)
165 "Default zone minimum TTL/negative TTL: four hours.")
167 (defvar *default-zone-ttl* (* 8 60 60)
168 "Default zone TTL (for records without explicit TTLs): 8 hours.")
170 (defvar *default-mx-priority* 50
171 "Default MX priority.")
173 ;;;--------------------------------------------------------------------------
174 ;;; Serial numbering.
176 (defun make-zone-serial (name)
177 "Given a zone NAME, come up with a new serial number. This will (very
178 carefully) update a file ZONE.serial in the current directory."
179 (let* ((file (format nil "~(~A~).serial" name))
180 (last (with-open-file (in file
182 :if-does-not-exist nil)
185 (now (multiple-value-bind
186 (sec min hr dy mon yr dow dstp tz)
188 (declare (ignore sec min hr dow dstp tz))
190 (seq (cond ((not (equal now (cdr last))) 0)
191 ((< (car last) 99) (1+ (car last)))
192 (t (error "Run out of sequence numbers for ~A" name)))))
193 (safely-writing (out file)
195 ";; Serial number file for zone ~A~%~
196 ;; (LAST-SEQ DAY MONTH YEAR)~%~
200 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
202 ;;;--------------------------------------------------------------------------
203 ;;; Zone variables and structures.
205 (defvar *zones* (make-hash-table :test #'equal)
206 "Map of known zones.")
208 (defun zone-find (name)
209 "Find a zone given its NAME."
210 (gethash (string-downcase (stringify name)) *zones*))
212 (defun (setf zone-find) (zone name)
213 "Make the zone NAME map to ZONE."
214 (setf (gethash (string-downcase (stringify name)) *zones*) zone))
216 (defstruct (zone-record (:conc-name zr-))
224 (defstruct (zone-subdomain (:conc-name zs-))
225 "A subdomain. Slightly weird. Used internally by zone-process-records
226 below, and shouldn't escape."
231 ;;;--------------------------------------------------------------------------
232 ;;; Zone infrastructure.
234 (defun zone-process-records (rec ttl func)
235 "Sort out the list of records in REC, calling FUNC for each one. TTL is
236 the default time-to-live for records which don't specify one."
237 (labels ((sift (rec ttl)
238 (collecting (top sub)
244 (setf ttl (pop rec)))
246 (collect (make-zone-record :type r
251 (dolist (name (listify (car r)))
252 (collect (make-zone-subdomain :name name
257 (error "Unexpected record form ~A" (car r))))))))
258 (process (rec dom ttl defsubp)
259 (multiple-value-bind (top sub) (sift rec ttl)
260 (if (and dom (null top) sub)
262 (process (zs-records s)
266 (process (zs-records s)
267 (cons (zs-name s) dom)
272 (join-strings #\. (reverse dom))))))
274 (setf (zr-name zr) name)
275 (setf (zr-defsubp zr) defsubp)
278 (process (zs-records s)
279 (cons (zs-name s) dom)
282 (process rec nil ttl nil)))
284 (defun zone-parse-host (f zname)
285 "Parse a host name F: if F ends in a dot then it's considered absolute;
286 otherwise it's relative to ZNAME."
287 (setf f (stringify f))
288 (cond ((string= f "@") (stringify zname))
289 ((and (plusp (length f))
290 (char= (char f (1- (length f))) #\.))
291 (string-downcase (subseq f 0 (1- (length f)))))
292 (t (string-downcase (concatenate 'string f "."
293 (stringify zname))))))
294 (defun default-rev-zone (base bytes)
295 "Return the default reverse-zone name for the given BASE address and number
296 of fixed leading BYTES."
297 (join-strings #\. (collecting ()
298 (loop for i from (- 3 bytes) downto 0
299 do (collect (ipaddr-byte base i)))
300 (collect "in-addr.arpa"))))
302 (defun zone-name-from-net (net &optional bytes)
303 "Given a NET, and maybe the BYTES to use, convert to the appropriate
304 subdomain of in-addr.arpa."
305 (let ((ipn (net-get-as-ipnet net)))
306 (with-ipnet (net mask) ipn
308 (setf bytes (- 4 (ipnet-changeable-bytes mask))))
311 for i from (- 4 bytes) below 4
312 collect (logand #xff (ash net (* -8 i))))
313 (list "in-addr.arpa"))))))
315 (defun zone-net-from-name (name)
316 "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
317 (let* ((name (string-downcase (stringify name)))
319 (suffix ".in-addr.arpa")
320 (sufflen (length suffix))
323 (end (- len sufflen)))
324 (unless (and (> len sufflen)
325 (string= name suffix :start1 end))
326 (error "`~A' not in ~A." name suffix))
329 for dot = (position #\. name :start start :end end)
330 for byte = (parse-integer name
333 do (setf addr (logior addr (ash byte (* 8 n))))
336 do (error "Can't deduce network from ~A." name)
338 do (setf start (1+ dot)))
339 (setf addr (ash addr (* 8 (- 4 n))))
340 (make-ipnet addr (* 8 n))))
342 (defun zone-reverse-records (records net list bytes dom)
343 "Construct a reverse zone given a forward zone's RECORDS list, the NET that
344 the reverse zone is to serve, a LIST to collect the records into, how
345 many BYTES of data need to end up in the zone, and the DOM-ain suffix."
347 (when (and (eq (zr-type zr) :a)
348 (not (zr-defsubp zr))
349 (ipaddr-networkp (zr-data zr) net))
350 (collect (make-zone-record
351 :name (string-downcase
356 (collect (logand #xff (ash (zr-data zr)
364 (defun zone-reverse (data name list)
365 "Process a :reverse record's DATA, for a domain called NAME, and add the
366 records to the LIST."
368 (net &key bytes zones)
370 (setf net (zone-parse-net net name))
371 (dolist (z (or (listify zones)
372 (hash-table-keys *zones*)))
373 (zone-reverse-records (zone-records (zone-find z))
377 (ipnet-changeable-bytes (ipnet-mask net)))
380 (defun zone-parse-net (net name)
381 "Given a NET, and the NAME of a domain to guess from if NET is null,
382 return the ipnet for the network."
384 (net-get-as-ipnet net)
385 (zone-net-from-name name)))
387 (defun zone-cidr-delg-default-name (ipn bytes)
388 "Given a delegated net IPN and the parent's number of changing BYTES,
389 return the default deletate zone prefix."
390 (with-ipnet (net mask) ipn
394 for i from (1- bytes) downto 0
395 until (zerop (logand mask (ash #xff (* 8 i))))
396 collect (logand #xff (ash net (* -8 i))))))))
398 (defun zone-cidr-delegation (data name ttl list)
399 "Given :cidr-delegation info DATA, for a record called NAME and the current
400 TTL, write lots of CNAME records to LIST."
404 (setf net (zone-parse-net net name))
406 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
407 (dolist (map (cdr data))
409 (tnet &optional tdom)
411 (setf tnet (zone-parse-net tnet name))
412 (unless (ipnet-subnetp net tnet)
413 (error "~A is not a subnet of ~A."
419 (list (zone-cidr-delg-default-name tnet bytes)
421 (setf tdom (string-downcase tdom))
422 (dotimes (i (ipnet-hosts tnet))
423 (let* ((addr (ipnet-host tnet i))
424 (tail (join-strings #\.
426 for i from 0 below bytes
429 (ash addr (* 8 i)))))))
430 (collect (make-zone-record
431 :name (join-strings #\.
435 :data (join-strings #\. (list tail tdom)))
438 ;;;--------------------------------------------------------------------------
439 ;;; Zone form parsing.
441 (defun zone-parse-head (head)
442 "Parse the HEAD of a zone form. This has the form
444 (NAME &key :source :admin :refresh :retry
445 :expire :min-ttl :ttl :serial)
447 though a singleton NAME needn't be a list. Returns the default TTL and an
448 soa structure representing the zone head."
452 (source *default-zone-source*)
453 (admin (or *default-zone-admin*
454 (format nil "hostmaster@~A" zname)))
455 (refresh *default-zone-refresh*)
456 (retry *default-zone-retry*)
457 (expire *default-zone-expire*)
458 (min-ttl *default-zone-min-ttl*)
460 (serial (make-zone-serial zname)))
463 (timespec-seconds ttl)
464 (make-soa :admin admin
465 :source (zone-parse-host source zname)
466 :refresh (timespec-seconds refresh)
467 :retry (timespec-seconds retry)
468 :expire (timespec-seconds expire)
469 :min-ttl (timespec-seconds min-ttl)
472 (defmacro defzoneparse (types (name data list
473 &key (zname (gensym "ZNAME"))
475 (defsubp (gensym "DEFSUBP")))
477 "Define a new zone record type (or TYPES -- a list of synonyms is
478 permitted). The arguments are as follows:
480 NAME The name of the record to be added.
482 DATA The content of the record to be added (a single object, unevaluated).
484 LIST A function to add a record to the zone. See below.
486 ZNAME The name of the zone being constructed.
488 TTL The TTL for this record.
490 DEFSUBP Whether this is the default subdomain for this entry.
492 You get to choose your own names for these. ZNAME, TTL and DEFSUBP are
493 optional: you don't have to accept them if you're not interested.
495 The LIST argument names a function to be bound in the body to add a new
496 low-level record to the zone. It has the prototype
498 (LIST &key :name :type :data :ttl :defsubp)
500 Except for defsubp, these default to the above arguments (even if you didn't
501 accept the arguments)."
502 (setf types (listify types))
503 (let* ((type (car types))
504 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
505 (multiple-value-bind (doc decls body) (parse-body body)
506 (with-gensyms (col tname ttype tttl tdata tdefsubp i)
509 (setf (get ,i 'zone-parse) ',func))
510 (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
513 (declare (ignorable ,zname ,defsubp))
514 (flet ((,list (&key ((:name ,tname) ,name)
515 ((:type ,ttype) ,type)
516 ((:data ,tdata) ,data)
518 ((:defsubp ,tdefsubp) nil))
519 (collect (make-zone-record :name ,tname
528 (defun zone-parse-records (zone records)
529 (let ((zname (zone-name zone)))
530 (with-collection (rec)
531 (flet ((parse-record (zr)
532 (let ((func (or (get (zr-type zr) 'zone-parse)
533 (error "No parser for record ~A."
535 (name (and (zr-name zr)
536 (stringify (zr-name zr)))))
540 (let ((len (length name)))
542 (char/= (char name (1- len)) #\.))
543 (setf name (join-strings #\.
544 (list name zname))))))
552 (zone-process-records records
553 (zone-default-ttl zone)
555 (setf (zone-records zone) (nconc (zone-records zone) rec)))))
557 (defun zone-parse (zf)
558 "Parse a ZONE form. The syntax of a zone form is as follows:
561 ZONE-HEAD ZONE-RECORD*
564 ((NAME*) ZONE-RECORD*)
566 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
567 (let ((zone (make-zone :name zname
571 (zone-parse-records zone (cdr zf))
574 (defun zone-create (zf)
575 "Zone construction function. Given a zone form ZF, construct the zone and
576 add it to the table."
577 (let* ((zone (zone-parse zf))
578 (name (zone-name zone)))
579 (setf (zone-find name) zone)
582 (defmacro defzone (soa &rest zf)
583 "Zone definition macro."
584 `(zone-create '(,soa ,@zf)))
586 (defmacro defrevzone (head &rest zf)
587 "Define a reverse zone, with the correct name."
592 (when (and soa-args (integerp (car soa-args)))
593 (setf bytes (pop soa-args)))
594 `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
596 ;;;--------------------------------------------------------------------------
597 ;;; Zone record parsers.
599 (defzoneparse :a (name data rec :defsubp defsubp)
601 (rec :data (parse-ipaddr data) :defsubp defsubp))
603 (defzoneparse :ptr (name data rec :zname zname)
605 (rec :data (zone-parse-host data zname)))
607 (defzoneparse :cname (name data rec :zname zname)
609 (rec :data (zone-parse-host data zname)))
611 (defzoneparse :mx (name data rec :zname zname)
612 ":mx ((HOST :prio INT :ip IPADDR)*)"
613 (dolist (mx (listify data))
615 (mxname &key (prio *default-mx-priority*) ip)
617 (let ((host (zone-parse-host mxname zname)))
618 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
619 (rec :data (cons host prio))))))
621 (defzoneparse :ns (name data rec :zname zname)
622 ":ns ((HOST :ip IPADDR)*)"
623 (dolist (ns (listify data))
627 (let ((host (zone-parse-host nsname zname)))
628 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
631 (defzoneparse :alias (name data rec :zname zname)
633 (dolist (a (listify data))
634 (rec :name (zone-parse-host a zname)
638 (defzoneparse :net (name data rec)
640 (dolist (net (listify data))
641 (let ((n (net-get-as-ipnet net)))
642 (rec :name (zone-parse-host "net" name)
645 (rec :name (zone-parse-host "mask" name)
647 :data (ipnet-mask n))
648 (rec :name (zone-parse-host "broadcast" name)
650 :data (ipnet-broadcast n)))))
652 (defzoneparse (:rev :reverse) (name data rec)
653 ":reverse ((NET :bytes BYTES) ZONE*)"
654 (setf data (listify data))
658 (setf net (zone-parse-net net name))
660 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
661 (dolist (z (or (cdr data)
662 (hash-table-keys *zones*)))
663 (dolist (zr (zone-records (zone-find z)))
664 (when (and (eq (zr-type zr) :a)
665 (not (zr-defsubp zr))
666 (ipaddr-networkp (zr-data zr) net))
667 (rec :name (string-downcase
672 (collect (logand #xff (ash (zr-data zr)
677 :data (zr-name zr)))))))
679 (defzoneparse (:cidr-delegation :cidr) (name data rec)
680 ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
684 (setf net (zone-parse-net net name))
686 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
687 (dolist (map (cdr data))
689 (tnet &optional tdom)
691 (setf tnet (zone-parse-net tnet name))
692 (unless (ipnet-subnetp net tnet)
693 (error "~A is not a subnet of ~A."
697 (with-ipnet (net mask) tnet
701 (append (reverse (loop
702 for i from (1- bytes) downto 0
703 until (zerop (logand mask
707 (ash net (* -8 i)))))
709 (setf tdom (string-downcase tdom))
710 (dotimes (i (ipnet-hosts tnet))
711 (let* ((addr (ipnet-host tnet i))
712 (tail (join-strings #\.
714 for i from 0 below bytes
717 (ash addr (* 8 i)))))))
718 (rec :name (format nil "~A.~A" tail name)
720 :data (format nil "~A.~A" tail tdom))))))))
722 ;;;--------------------------------------------------------------------------
723 ;;; Zone file output.
725 (defun zone-write (zone &optional (stream *standard-output*))
726 "Write a ZONE's records to STREAM."
727 (labels ((fix-admin (a)
728 (let ((at (position #\@ a))
729 (s (concatenate 'string (string-downcase a) ".")))
731 (setf (char s at) #\.))
736 (let* ((h (string-downcase (stringify h)))
738 (r (string-downcase (zone-name zone)))
740 (cond ((string= r h) "@")
742 (char= (char h (- hl rl 1)) #\.)
743 (string= h r :start1 (- hl rl)))
744 (subseq h 0 (- hl rl 1)))
745 (t (concatenate 'string h "."))))))
747 (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
748 (fix-host (zr-name zr))
749 (and (/= (zr-ttl zr) (zone-default-ttl zone))
751 (string-upcase (symbol-name (zr-type zr))))))
753 ;;; Zone file `~(~A~)'
759 (iso-date :now :datep t :timep t)
760 (zone-default-ttl zone))
761 (let ((soa (zone-soa zone)))
763 ~A~30TIN SOA~40T~A ~A (
765 ~45T~10D~60T ;refresh
768 ~45T~10D )~60T ;min-ttl~2%"
769 (fix-host (zone-name zone))
770 (fix-host (soa-source soa))
771 (fix-admin (soa-admin soa))
777 (dolist (zr (zone-records zone))
781 (format stream "~A~%" (ipaddr-string (zr-data zr))))
784 (format stream "~A~%" (fix-host (zr-data zr))))
787 (format stream "~A~%" (fix-host (zr-data zr))))
790 (let ((mx (zr-data zr)))
791 (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
794 (format stream "~S~%" (stringify (zr-data zr))))))))
796 (defun zone-save (zones)
797 "Write the named ZONES to files. If no zones are given, write all the
800 (setf zones (hash-table-keys *zones*)))
803 (let ((zz (zone-find z)))
805 (error "Unknown zone `~A'." z))
806 (let ((stream (safely-open-output-stream safe
810 (zone-write zz stream))))))
812 ;;;----- That's all, folks --------------------------------------------------