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
31 (:import-from #:net #:round-down #:round-up))
35 ;;;--------------------------------------------------------------------------
36 ;;; Various random utilities.
39 "Convert X to an integer in the most straightforward way."
42 (defun from-mixed-base (base val)
43 "BASE is a list of the ranges for the `digits' of a mixed-base
44 representation. Convert VAL, a list of digits, into an integer."
45 (do ((base base (cdr base))
46 (val (cdr val) (cdr val))
47 (a (car val) (+ (* a (car base)) (car val))))
48 ((or (null base) (null val)) a)))
50 (defun to-mixed-base (base val)
51 "BASE is a list of the ranges for the `digits' of a mixed-base
52 representation. Convert VAL, an integer, into a list of digits."
53 (let ((base (reverse base))
59 (multiple-value-bind (q r) (floor val (pop base))
63 (export 'timespec-seconds)
64 (defun timespec-seconds (ts)
65 "Convert a timespec TS to seconds.
67 A timespec may be a real count of seconds, or a list (COUNT UNIT). UNIT
68 may be any of a number of obvious time units."
70 ((realp ts) (floor ts))
72 (error "Unknown timespec format ~A" ts))
74 (timespec-seconds (car ts)))
75 (t (+ (to-integer (* (car ts)
76 (case (intern (string-upcase
77 (stringify (cadr ts)))
79 ((s sec secs second seconds) 1)
80 ((m min mins minute minutes) 60)
81 ((h hr hrs hour hours) #.(* 60 60))
82 ((d dy dys day days) #.(* 24 60 60))
83 ((w wk wks week weeks) #.(* 7 24 60 60))
84 ((y yr yrs year years) #.(* 365 24 60 60))
85 (t (error "Unknown time unit ~A"
87 (timespec-seconds (cddr ts))))))
89 (defun hash-table-keys (ht)
90 "Return a list of the keys in hashtable HT."
92 (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
94 (defun iso-date (&optional time &key datep timep (sep #\ ))
95 "Construct a textual date or time in ISO format.
97 The TIME is the universal time to convert, which defaults to now; DATEP is
98 whether to emit the date; TIMEP is whether to emit the time, and
99 SEP (default is space) is how to separate the two."
101 (sec min hr day mon yr dow dstp tz)
102 (decode-universal-time (if (or (null time) (eq time :now))
105 (declare (ignore dow dstp tz))
106 (with-output-to-string (s)
108 (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
112 (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
114 ;;;--------------------------------------------------------------------------
118 (defstruct (soa (:predicate soap))
119 "Start-of-authority record information."
129 (defstruct (mx (:predicate mxp))
130 "Mail-exchange record information."
135 (defstruct (zone (:predicate zonep))
142 ;;;--------------------------------------------------------------------------
143 ;;; Zone defaults. It is intended that scripts override these.
145 (export '*default-zone-source*)
146 (defvar *default-zone-source*
147 (let ((hn (gethostname)))
148 (and hn (concatenate 'string (canonify-hostname hn) ".")))
149 "The default zone source: the current host's name.")
151 (export '*default-zone-refresh*)
152 (defvar *default-zone-refresh* (* 24 60 60)
153 "Default zone refresh interval: one day.")
155 (export '*default-zone-admin*)
156 (defvar *default-zone-admin* nil
157 "Default zone administrator's email address.")
159 (export '*default-zone-retry*)
160 (defvar *default-zone-retry* (* 60 60)
161 "Default znoe retry interval: one hour.")
163 (export '*default-zone-expire*)
164 (defvar *default-zone-expire* (* 14 24 60 60)
165 "Default zone expiry time: two weeks.")
167 (export '*default-zone-min-ttl*)
168 (defvar *default-zone-min-ttl* (* 4 60 60)
169 "Default zone minimum TTL/negative TTL: four hours.")
171 (export '*default-zone-ttl*)
172 (defvar *default-zone-ttl* (* 8 60 60)
173 "Default zone TTL (for records without explicit TTLs): 8 hours.")
175 (export '*default-mx-priority*)
176 (defvar *default-mx-priority* 50
177 "Default MX priority.")
179 ;;;--------------------------------------------------------------------------
180 ;;; Zone variables and structures.
182 (defvar *zones* (make-hash-table :test #'equal)
183 "Map of known zones.")
186 (defun zone-find (name)
187 "Find a zone given its NAME."
188 (gethash (string-downcase (stringify name)) *zones*))
189 (defun (setf zone-find) (zone name)
190 "Make the zone NAME map to ZONE."
191 (setf (gethash (string-downcase (stringify name)) *zones*) zone))
193 (export 'zone-record)
194 (defstruct (zone-record (:conc-name zr-))
202 (export 'zone-subdomain)
203 (defstruct (zone-subdomain (:conc-name zs-))
206 Slightly weird. Used internally by `zone-process-records', and shouldn't
212 (export '*zone-output-path*)
213 (defvar *zone-output-path* nil
214 "Pathname defaults to merge into output files.
216 If this is nil then use the prevailing `*default-pathname-defaults*'.
217 This is not the same as capturing the `*default-pathname-defaults*' from
220 (export '*preferred-subnets*)
221 (defvar *preferred-subnets* nil
222 "Subnets to prefer when selecting defaults.")
224 ;;;--------------------------------------------------------------------------
225 ;;; Zone infrastructure.
227 (defun zone-file-name (zone type)
228 "Choose a file name for a given ZONE and TYPE."
229 (merge-pathnames (make-pathname :name (string-downcase zone)
230 :type (string-downcase type))
231 (or *zone-output-path* *default-pathname-defaults*)))
233 (export 'zone-preferred-subnet-p)
234 (defun zone-preferred-subnet-p (name)
235 "Answer whether NAME (a string or symbol) names a preferred subnet."
236 (member name *preferred-subnets* :test #'string-equal))
238 (export 'preferred-subnet-case)
239 (defmacro preferred-subnet-case (&body clauses)
240 "Execute a form based on which networks are considered preferred.
242 The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
243 whose SUBNETS (a list or single symbol, not evaluated) are listed in
244 `*preferred-subnets*'. If SUBNETS is the symbol `t' then the clause
247 ,@(mapcar (lambda (clause)
248 (let ((subnets (car clause)))
249 (cons (cond ((eq subnets t)
252 `(or ,@(mapcar (lambda (subnet)
253 `(zone-preferred-subnet-p
257 `(zone-preferred-subnet-p ',subnets)))
261 (export 'zone-parse-host)
262 (defun zone-parse-host (f zname)
263 "Parse a host name F.
265 If F ends in a dot then it's considered absolute; otherwise it's relative
267 (setf f (stringify f))
268 (cond ((string= f "@") (stringify zname))
269 ((and (plusp (length f))
270 (char= (char f (1- (length f))) #\.))
271 (string-downcase (subseq f 0 (1- (length f)))))
272 (t (string-downcase (concatenate 'string f "."
273 (stringify zname))))))
275 (export 'zone-make-name)
276 (defun zone-make-name (prefix zone-name)
277 "Compute a full domain name from a PREFIX and a ZONE-NAME.
279 If the PREFIX ends with `.' then it's absolute already; otherwise, append
280 the ZONE-NAME, separated with a `.'. If PREFIX is nil, or `@', then
281 return the ZONE-NAME only."
282 (if (or (not prefix) (string= prefix "@"))
284 (let ((len (length prefix)))
285 (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
286 (join-strings #\. (list prefix zone-name))
289 (export 'zone-records-sorted)
290 (defun zone-records-sorted (zone)
291 "Return the ZONE's records, in a pleasant sorted order."
292 (sort (copy-seq (zone-records zone))
294 (let* ((name-a (zr-name zr-a)) (pos-a (length name-a))
295 (name-b (zr-name zr-b)) (pos-b (length name-b)))
296 (loop (let ((dot-a (or (position #\. name-a
297 :from-end t :end pos-a)
299 (dot-b (or (position #\. name-b
300 :from-end t :end pos-b)
302 (cond ((string< name-a name-b
303 :start1 (1+ dot-a) :end1 pos-a
304 :start2 (1+ dot-b) :end2 pos-b)
306 ((string> name-a name-b
307 :start1 (1+ dot-a) :end1 pos-a
308 :start2 (1+ dot-b) :end2 pos-b)
311 (return (string< (zr-type zr-a) (zr-type zr-b))))
318 (setf pos-b dot-b)))))))))
320 ;;;--------------------------------------------------------------------------
321 ;;; Serial numbering.
323 (export 'make-zone-serial)
324 (defun make-zone-serial (name)
325 "Given a zone NAME, come up with a new serial number.
327 This will (very carefully) update a file ZONE.serial in the current
329 (let* ((file (zone-file-name name :serial))
330 (last (with-open-file (in file
332 :if-does-not-exist nil)
335 (now (multiple-value-bind
336 (sec min hr dy mon yr dow dstp tz)
338 (declare (ignore sec min hr dow dstp tz))
340 (seq (cond ((not (equal now (cdr last))) 0)
341 ((< (car last) 99) (1+ (car last)))
342 (t (error "Run out of sequence numbers for ~A" name)))))
343 (safely-writing (out file)
345 ";; Serial number file for zone ~A~%~
346 ;; (LAST-SEQ DAY MONTH YEAR)~%~
350 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
352 ;;;--------------------------------------------------------------------------
353 ;;; Zone form parsing.
355 (defun zone-process-records (rec ttl func)
356 "Sort out the list of records in REC, calling FUNC for each one.
358 TTL is the default time-to-live for records which don't specify one.
360 REC is a list of records of the form
362 ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)
364 The various kinds of entries have the following meanings.
366 :ttl TTL Set the TTL for subsequent records (at this level of
369 TYPE DATA Define a record with a particular TYPE and DATA.
370 Record types are defined using `defzoneparse' and
371 the syntax of the data is idiosyncratic.
373 ((LABEL ...) . REC) Define records for labels within the zone. Any
374 records defined within REC will have their domains
375 prefixed by each of the LABELs. A singleton list
376 of labels may instead be written as a single
377 label. Note, therefore, that
379 (host (sub :a \"169.254.1.1\"))
381 defines a record for `host.sub' -- not `sub.host'.
383 If REC contains no top-level records, but it does define records for a
384 label listed in `*preferred-subnets*', then the records for the first such
385 label are also promoted to top-level.
387 The FUNC is called for each record encountered, represented as a
388 `zone-record' object. Zone parsers are not called: you get the record
389 types and data from the input form; see `zone-parse-records' if you want
392 (labels ((sift (rec ttl)
393 ;; Parse the record list REC into lists of `zone-record' and
394 ;; `zone-subdomain' objects, sorting out TTLs and so on.
395 ;; Returns them as two values.
397 (collecting (top sub)
403 (setf ttl (pop rec)))
405 (collect (make-zone-record :type r
410 (dolist (name (listify (car r)))
411 (collect (make-zone-subdomain :name name
416 (error "Unexpected record form ~A" (car r))))))))
418 (process (rec dom ttl)
419 ;; Recursirvely process the record list REC, with a list DOM of
420 ;; prefix labels, and a default TTL. Promote records for a
421 ;; preferred subnet to toplevel if there are no toplevel records
424 (multiple-value-bind (top sub) (sift rec ttl)
425 (if (and dom (null top) sub)
427 (or (find-if (lambda (s)
428 (some #'zone-preferred-subnet-p
429 (listify (zs-name s))))
433 (process (zs-records preferred)
435 (zs-ttl preferred))))
438 (join-strings #\. (reverse dom))))))
440 (setf (zr-name zr) name)
443 (process (zs-records s)
444 (cons (zs-name s) dom)
447 ;; Process the records we're given with no prefix.
448 (process rec nil ttl)))
450 (defun zone-parse-head (head)
451 "Parse the HEAD of a zone form.
455 (NAME &key :source :admin :refresh :retry
456 :expire :min-ttl :ttl :serial)
458 though a singleton NAME needn't be a list. Returns the default TTL and an
459 soa structure representing the zone head."
463 (source *default-zone-source*)
464 (admin (or *default-zone-admin*
465 (format nil "hostmaster@~A" zname)))
466 (refresh *default-zone-refresh*)
467 (retry *default-zone-retry*)
468 (expire *default-zone-expire*)
469 (min-ttl *default-zone-min-ttl*)
471 (serial (make-zone-serial zname)))
473 (values (string-downcase zname)
474 (timespec-seconds ttl)
475 (make-soa :admin admin
476 :source (zone-parse-host source zname)
477 :refresh (timespec-seconds refresh)
478 :retry (timespec-seconds retry)
479 :expire (timespec-seconds expire)
480 :min-ttl (timespec-seconds min-ttl)
483 (export 'defzoneparse)
484 (defmacro defzoneparse (types (name data list
485 &key (prefix (gensym "PREFIX"))
486 (zname (gensym "ZNAME"))
487 (ttl (gensym "TTL")))
489 "Define a new zone record type.
491 The arguments are as follows:
493 TYPES A singleton type symbol, or a list of aliases.
495 NAME The name of the record to be added.
497 DATA The content of the record to be added (a single object,
500 LIST A function to add a record to the zone. See below.
502 PREFIX The prefix tag used in the original form.
504 ZNAME The name of the zone being constructed.
506 TTL The TTL for this record.
508 You get to choose your own names for these. ZNAME, PREFIX and TTL are
509 optional: you don't have to accept them if you're not interested.
511 The LIST argument names a function to be bound in the body to add a new
512 low-level record to the zone. It has the prototype
514 (LIST &key :name :type :data :ttl :make-ptr-p)
516 These (except MAKE-PTR-P, which defaults to nil) default to the above
517 arguments (even if you didn't accept the arguments)."
518 (setf types (listify types))
519 (let* ((type (car types))
520 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
521 (with-parsed-body (body decls doc) body
522 (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
525 (setf (get ,i 'zone-parse) ',func))
526 (defun ,func (,prefix ,zname ,data ,ttl ,col)
529 (let ((,name (zone-make-name ,prefix ,zname)))
530 (flet ((,list (&key ((:name ,tname) ,name)
531 ((:type ,ttype) ,type)
532 ((:data ,tdata) ,data)
534 ((:make-ptr-p ,tmakeptrp) nil))
535 #+cmu (declare (optimize ext:inhibit-warnings))
536 (collect (make-zone-record :name ,tname
540 :make-ptr-p ,tmakeptrp)
545 (export 'zone-parse-records)
546 (defun zone-parse-records (zname ttl records)
547 "Parse a sequence of RECORDS and return a list of raw records.
549 The records are parsed relative to the zone name ZNAME, and using the
552 (flet ((parse-record (zr)
553 (let ((func (or (get (zr-type zr) 'zone-parse)
554 (error "No parser for record ~A."
556 (name (and (zr-name zr) (stringify (zr-name zr)))))
557 (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
558 (zone-process-records records ttl #'parse-record))))
561 (defun zone-parse (zf)
564 The syntax of a zone form is as follows:
567 ZONE-HEAD ZONE-RECORD*
570 ((NAME*) ZONE-RECORD*)
572 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
573 (make-zone :name zname
576 :records (zone-parse-records zname ttl (cdr zf)))))
578 (export 'zone-create)
579 (defun zone-create (zf)
580 "Zone construction function. Given a zone form ZF, construct the zone and
581 add it to the table."
582 (let* ((zone (zone-parse zf))
583 (name (zone-name zone)))
584 (setf (zone-find name) zone)
588 (defmacro defzone (soa &body zf)
589 "Zone definition macro."
590 `(zone-create '(,soa ,@zf)))
592 (export '*address-family*)
593 (defvar *address-family* t
594 "The default address family. This is bound by `defrevzone'.")
597 (defmacro defrevzone (head &body zf)
598 "Define a reverse zone, with the correct name."
599 (destructuring-bind (nets &rest args
600 &key &allow-other-keys
601 (family '*address-family*)
605 `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
606 (let ((*address-family* (ipnet-family ,ipn)))
607 (zone-create `((,(reverse-domain ,ipn ,prefix-bits)
608 ,@',(loop for (k v) on args by #'cddr
610 '(:family :prefix-bits))
614 (export 'map-host-addresses)
615 (defun map-host-addresses (func addr &key (family *address-family*))
616 "Call FUNC for each address denoted by ADDR (a `host-parse' address)."
618 (dolist (a (host-addrs (host-parse addr family)))
622 (defmacro do-host ((addr spec &key (family *address-family*)) &body body)
623 "Evaluate BODY, binding ADDR to each address denoted by SPEC."
624 `(dolist (,addr (host-addrs (host-parse ,spec ,family)))
627 (export 'zone-set-address)
628 (defun zone-set-address (rec addrspec &rest args
629 &key (family *address-family*) name ttl make-ptr-p)
630 "Write records (using REC) defining addresses for ADDRSPEC."
631 (declare (ignore name ttl make-ptr-p))
632 (let ((key-args (loop for (k v) on args by #'cddr
633 unless (eq k :family)
635 (do-host (addr addrspec :family family)
636 (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))
638 ;;;--------------------------------------------------------------------------
639 ;;; Zone record parsers.
641 (defzoneparse :a (name data rec)
643 (zone-set-address #'rec data :make-ptr-p t :family :ipv4))
645 (defzoneparse :aaaa (name data rec)
647 (zone-set-address #'rec data :make-ptr-p t :family :ipv6))
649 (defzoneparse :addr (name data rec)
651 (zone-set-address #'rec data :make-ptr-p t))
653 (defzoneparse :svc (name data rec)
655 (zone-set-address #'rec data))
657 (defzoneparse :ptr (name data rec :zname zname)
659 (rec :data (zone-parse-host data zname)))
661 (defzoneparse :cname (name data rec :zname zname)
663 (rec :data (zone-parse-host data zname)))
665 (defzoneparse :txt (name data rec)
667 (rec :data (listify data)))
669 (export '*dkim-pathname-defaults*)
670 (defvar *dkim-pathname-defaults*
671 (make-pathname :directory '(:relative "keys")
674 (defzoneparse :dkim (name data rec)
675 ":dkim (KEYFILE {:TAG VALUE}*)"
676 (destructuring-bind (file &rest plist) (listify data)
677 (let ((things nil) (out nil))
680 (push (get-output-stream-string out) things)
683 (let ((len (length text)))
684 (when (and out (> (+ (file-position out)
690 (unless out (setf out (make-string-output-stream)))
691 (write-string text out))
696 (push (subseq text i (min j len)) things))))))))
697 (do ((p plist (cddr p)))
699 (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
700 (emit (with-output-to-string (out)
701 (write-string "p=" out)
704 (in (merge-pathnames file *dkim-pathname-defaults*))
706 (when (string= (read-line in)
707 "-----BEGIN PUBLIC KEY-----")
710 (let ((line (read-line in)))
711 (if (string= line "-----END PUBLIC KEY-----")
713 (write-string line out)))))))))
715 :data (nreverse things)))))
717 (eval-when (:load-toplevel :execute)
718 (dolist (item '((sshfp-algorithm rsa 1)
719 (sshfp-algorithm dsa 2)
720 (sshfp-algorithm ecdsa 3)
722 (sshfp-type sha-256 2)))
723 (destructuring-bind (prop sym val) item
724 (setf (get sym prop) val)
727 (export '*sshfp-pathname-defaults*)
728 (defvar *sshfp-pathname-defaults*
729 (make-pathname :directory '(:relative "keys")
732 (defzoneparse :sshfp (name data rec)
733 ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
735 (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
736 (loop (let ((line (read-line in nil)))
737 (unless line (return))
738 (let ((words (str-split-words line)))
740 (when (string= (car words) "IN") (pop words))
741 (unless (and (string= (car words) "SSHFP")
742 (= (length words) 4))
743 (error "Invalid SSHFP record."))
745 (destructuring-bind (alg type fpr) words
746 (rec :data (list (parse-integer alg)
749 (flet ((lookup (what prop)
752 (symbol (or (get what prop)
753 (error "~S is not a known ~A" what prop))))))
754 (dolist (item (listify data))
755 (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
757 (rec :data (list (lookup alg 'sshfp-algorithm)
758 (lookup type 'sshfp-type)
761 (defzoneparse :mx (name data rec :zname zname)
762 ":mx ((HOST :prio INT :ip IPADDR)*)"
763 (dolist (mx (listify data))
765 (mxname &key (prio *default-mx-priority*) ip)
767 (let ((host (zone-parse-host mxname zname)))
768 (when ip (zone-set-address #'rec ip :name host))
769 (rec :data (cons host prio))))))
771 (defzoneparse :ns (name data rec :zname zname)
772 ":ns ((HOST :ip IPADDR)*)"
773 (dolist (ns (listify data))
777 (let ((host (zone-parse-host nsname zname)))
778 (when ip (zone-set-address #'rec ip :name host))
781 (defzoneparse :alias (name data rec :zname zname)
783 (dolist (a (listify data))
784 (rec :name (zone-parse-host a zname)
788 (defzoneparse :srv (name data rec :zname zname)
789 ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
791 (destructuring-bind (servopts &rest providers) srv
793 (service &key ((:port default-port)) (protocol :tcp))
796 (let ((serv (serv-by-name service protocol)))
797 (setf default-port (and serv (serv-port serv)))))
798 (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
799 (dolist (prov providers)
804 (prio *default-mx-priority*)
808 (let ((host (zone-parse-host srvname zname)))
809 (when ip (zone-set-address #'rec ip :name host))
811 :data (list prio weight port host))))))))))
813 (defzoneparse :net (name data rec)
815 (dolist (net (listify data))
816 (dolist (ipn (net-ipnets (net-must-find net)))
817 (let* ((base (ipnet-net ipn))
818 (rrtype (ipaddr-rrtype base)))
819 (flet ((frob (kind addr)
821 (rec :name (zone-parse-host kind name)
825 (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn)))
826 (frob "bcast" (ipnet-broadcast ipn)))))))
828 (defzoneparse (:rev :reverse) (name data rec)
829 ":reverse ((NET &key :prefix-bits :family) ZONE*)
831 Add a reverse record each host in the ZONEs (or all zones) that lies
833 (setf data (listify data))
834 (destructuring-bind (net &key prefix-bits (family *address-family*))
837 (dolist (ipn (net-parse-to-ipnets net family))
838 (let* ((seen (make-hash-table :test #'equal))
839 (width (ipnet-width ipn))
840 (frag-len (if prefix-bits (- width prefix-bits)
841 (ipnet-changeable-bits width (ipnet-mask ipn)))))
842 (dolist (z (or (cdr data) (hash-table-keys *zones*)))
843 (dolist (zr (zone-records (zone-find z)))
844 (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn)))
846 (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
847 (let* ((frag (reverse-domain-fragment (zr-data zr)
849 (name (concatenate 'string frag "." name)))
850 (unless (gethash name seen)
851 (rec :name name :type :ptr
852 :ttl (zr-ttl zr) :data (zr-name zr))
853 (setf (gethash name seen) t))))))))))
855 (defzoneparse :multi (name data rec :zname zname :ttl ttl)
856 ":multi (((NET*) &key :start :end :family :suffix) . REC)
858 Output multiple records covering a portion of the reverse-resolution
859 namespace corresponding to the particular NETs. The START and END bounds
860 default to the most significant variable component of the
861 reverse-resolution domain.
863 The REC tail is a sequence of record forms (as handled by
864 `zone-process-records') to be emitted for each covered address. Within
865 the bodies of these forms, the symbol `*' will be replaced by the
866 domain-name fragment corresponding to the current host, optionally
867 followed by the SUFFIX.
871 (:multi ((delegated-subnet :start 8)
872 :ns (some.ns.delegated.example :ip \"169.254.5.2\")))
874 (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\")
877 Obviously, nested `:multi' records won't work well."
879 (destructuring-bind (nets &key start end (family *address-family*) suffix)
881 (dolist (net (listify nets))
882 (dolist (ipn (net-parse-to-ipnets net family))
883 (let* ((addr (ipnet-net ipn))
884 (width (ipaddr-width addr))
885 (comp-width (reverse-domain-component-width addr))
886 (end (round-up (or end
887 (ipnet-changeable-bits width
890 (start (round-down (or start (- end comp-width))
892 (map (ipnet-host-map ipn)))
893 (multiple-value-bind (host-step host-limit)
894 (ipnet-index-bounds map start end)
895 (do ((index 0 (+ index host-step)))
896 ((> index host-limit))
897 (let* ((addr (ipnet-index-host map index))
898 (frag (reverse-domain-fragment addr start end))
899 (target (concatenate 'string
901 (if (not suffix) frag
906 (dolist (zr (zone-parse-records (zone-make-name frag zname)
910 (rec :name (zr-name zr)
914 :make-ptr-p (zr-make-ptr-p zr)))))))))))
916 ;;;--------------------------------------------------------------------------
917 ;;; Building raw record vectors.
919 (defvar *record-vector* nil
920 "The record vector under construction.")
922 (defun rec-ensure (n)
923 "Ensure that at least N octets are spare in the current record."
924 (let ((want (+ n (fill-pointer *record-vector*)))
925 (have (array-dimension *record-vector* 0)))
926 (unless (<= want have)
927 (adjust-array *record-vector*
928 (do ((new (* 2 have) (* 2 new)))
929 ((<= want new) new))))))
931 (defun rec-byte (octets value)
932 "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record."
934 (do ((i (1- octets) (1- i)))
936 (vector-push (ldb (byte 8 (* 8 i)) value) *record-vector*)))
938 (defun rec-u8 (value)
939 "Append an 8-bit VALUE to the current record."
941 (defun rec-u16 (value)
942 "Append a 16-bit VALUE to the current record."
944 (defun rec-u32 (value)
945 "Append a 32-bit VALUE to the current record."
948 (defun rec-raw-string (s &key (start 0) end)
949 "Append (a (substring of) a raw string S to the current record.
951 No arrangement is made for reporting the length of the string. That must
952 be done by the caller, if necessary."
953 (setf-default end (length s))
954 (rec-ensure (- end start))
955 (do ((i start (1+ i)))
957 (vector-push (char-code (char s i)) *record-vector*)))
960 "Append a domain name S.
962 No attempt is made to perform compression of the name."
963 (let ((i 0) (n (length s)))
964 (loop (let* ((dot (position #\. s :start i))
967 (rec-raw-string s :start i :end lim)
974 (defmacro build-record (&body body)
975 "Build a raw record, and return it as a vector of octets."
976 `(let ((*record-vector* (make-array 256
977 :element-type '(unsigned-byte 8)
981 (copy-seq *record-vector*)))
983 ;;;--------------------------------------------------------------------------
984 ;;; Zone file output.
987 (defgeneric zone-write (format zone stream)
988 (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
990 (defvar *writing-zone* nil
991 "The zone currently being written.")
993 (defvar *zone-output-stream* nil
994 "Stream to write zone data on.")
996 (defmethod zone-write :around (format zone stream)
997 (declare (ignore format))
998 (let ((*writing-zone* zone)
999 (*zone-output-stream* stream))
1000 (call-next-method)))
1003 (defun zone-save (zones &key (format :bind))
1004 "Write the named ZONES to files. If no zones are given, write all the
1007 (setf zones (hash-table-keys *zones*)))
1010 (let ((zz (zone-find z)))
1012 (error "Unknown zone `~A'." z))
1013 (let ((stream (safely-open-output-stream safe
1014 (zone-file-name z :zone))))
1015 (zone-write format zz stream))))))
1017 ;;;--------------------------------------------------------------------------
1018 ;;; Bind format output.
1020 (export 'bind-hostname)
1021 (defun bind-hostname (hostname)
1024 (let* ((h (string-downcase (stringify hostname)))
1026 (r (string-downcase (zone-name *writing-zone*)))
1028 (cond ((string= r h) "@")
1030 (char= (char h (- hl rl 1)) #\.)
1031 (string= h r :start1 (- hl rl)))
1032 (subseq h 0 (- hl rl 1)))
1033 (t (concatenate 'string h "."))))))
1035 (export 'bind-record)
1036 (defgeneric bind-record (type zr))
1038 (defmethod zone-write ((format (eql :bind)) zone stream)
1040 ;;; Zone file `~(~A~)'
1046 (iso-date :now :datep t :timep t)
1047 (zone-default-ttl zone))
1048 (let* ((soa (zone-soa zone))
1049 (admin (let* ((name (soa-admin soa))
1050 (at (position #\@ name))
1051 (copy (format nil "~(~A~)." name)))
1053 (setf (char copy at) #\.))
1056 ~A~30TIN SOA~40T~A (
1057 ~55@A~60T ;administrator
1058 ~45T~10D~60T ;serial
1059 ~45T~10D~60T ;refresh
1061 ~45T~10D~60T ;expire
1062 ~45T~10D )~60T ;min-ttl~2%"
1063 (bind-hostname (zone-name zone))
1064 (bind-hostname (soa-source soa))
1071 (dolist (zr (zone-records-sorted zone))
1072 (bind-record (zr-type zr) zr)))
1074 (export 'bind-format-record)
1075 (defun bind-format-record (name ttl type format args)
1076 (format *zone-output-stream*
1077 "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
1078 (bind-hostname name)
1079 (and (/= ttl (zone-default-ttl *writing-zone*))
1081 (string-upcase (symbol-name type))
1084 (export 'bind-record-type)
1085 (defgeneric bind-record-type (type)
1086 (:method (type) type))
1088 (export 'bind-record-format-args)
1089 (defgeneric bind-record-format-args (type data)
1090 (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
1091 (:method ((type (eql :aaaa)) data) (list "~A" (ipaddr-string data)))
1092 (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
1093 (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
1094 (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
1095 (:method ((type (eql :mx)) data)
1096 (list "~2D ~A" (cdr data) (bind-hostname (car data))))
1097 (:method ((type (eql :srv)) data)
1098 (destructuring-bind (prio weight port host) data
1099 (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
1100 (:method ((type (eql :sshfp)) data)
1101 (cons "~2D ~2D ~A" data))
1102 (:method ((type (eql :txt)) data)
1103 (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
1104 (mapcar #'stringify data))))
1106 (defmethod bind-record (type zr)
1107 (destructuring-bind (format &rest args)
1108 (bind-record-format-args type (zr-data zr))
1109 (bind-format-record (zr-name zr)
1111 (bind-record-type type)
1114 ;;;--------------------------------------------------------------------------
1115 ;;; tinydns-data output format.
1117 (defun tinydns-output (code &rest fields)
1118 (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields))
1120 (defun tinydns-raw-record (type zr data)
1121 (tinydns-output #\: (zr-name zr) type
1122 (with-output-to-string (out)
1123 (dotimes (i (length data))
1124 (let ((byte (aref data i)))
1125 (if (or (<= byte 32)
1127 (member byte '(#\: #\\) :key #'char-code))
1128 (format out "\\~3,'0O" byte)
1129 (write-char (code-char byte) out)))))
1132 (defgeneric tinydns-record (type zr)
1133 (:method ((type (eql :a)) zr)
1134 (tinydns-output #\+ (zr-name zr)
1135 (ipaddr-string (zr-data zr)) (zr-ttl zr)))
1136 (:method ((type (eql :aaaa)) zr)
1137 (tinydns-output #\3 (zr-name zr)
1138 (format nil "~(~32,'0X~)" (ipaddr-addr (zr-data zr)))
1140 (:method ((type (eql :ptr)) zr)
1141 (tinydns-output #\^ (zr-name zr) (zr-data zr) (zr-ttl zr)))
1142 (:method ((type (eql :cname)) zr)
1143 (tinydns-output #\C (zr-name zr) (zr-data zr) (zr-ttl zr)))
1144 (:method ((type (eql :ns)) zr)
1145 (tinydns-output #\& (zr-name zr) nil (zr-data zr) (zr-ttl zr)))
1146 (:method ((type (eql :mx)) zr)
1147 (let ((name (car (zr-data zr)))
1148 (prio (cdr (zr-data zr))))
1149 (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr))))
1150 (:method ((type (eql :txt)) zr)
1151 (tinydns-raw-record 16 zr
1153 (dolist (s (zr-data zr))
1155 (rec-raw-string s)))))
1156 (:method ((type (eql :srv)) zr)
1157 (destructuring-bind (prio weight port host) (zr-data zr)
1158 (tinydns-raw-record 33 zr
1164 (:method ((type (eql :sshfp)) zr)
1165 (destructuring-bind (alg type fpr) (zr-data zr)
1166 (tinydns-raw-record 44 zr
1173 (rec-u8 (parse-integer fpr
1174 :start i :end (+ i 2)
1177 (defmethod zone-write ((format (eql :tinydns)) zone stream)
1179 ### Zone file `~(~A~)'
1183 (iso-date :now :datep t :timep t))
1184 (let ((soa (zone-soa zone)))
1188 (let* ((name (copy-seq (soa-admin soa)))
1189 (at (position #\@ name)))
1190 (when at (setf (char name at) #\.))
1196 (zone-default-ttl zone)))
1197 (dolist (zr (zone-records-sorted zone))
1198 (tinydns-record (zr-type zr) zr)))
1200 ;;;----- That's all, folks --------------------------------------------------