chiark / gitweb /
zone.lisp: Better documentation for reverse-zone directives.
[zone] / zone.lisp
CommitLineData
7e282fb5 1;;; -*-lisp-*-
2;;;
7e282fb5 3;;; DNS zone generation
4;;;
5;;; (c) 2005 Straylight/Edgeware
6;;;
7
8;;;----- Licensing notice ---------------------------------------------------
9;;;
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.
7fff3797 14;;;
7e282fb5 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.
7fff3797 19;;;
7e282fb5 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.
23
fe5fb85a
MW
24;;;--------------------------------------------------------------------------
25;;; Packaging.
26
7e282fb5 27(defpackage #:zone
716105aa
MW
28 (:use #:common-lisp
29 #:mdw.base #:mdw.str #:collect #:safely
afa2e2f1 30 #:net #:services))
fe5fb85a 31
7e282fb5 32(in-package #:zone)
33
fe5fb85a 34;;;--------------------------------------------------------------------------
fe5fb85a
MW
35;;; Various random utilities.
36
37(defun to-integer (x)
38 "Convert X to an integer in the most straightforward way."
39 (floor (rational x)))
40
41(defun from-mixed-base (base val)
42 "BASE is a list of the ranges for the `digits' of a mixed-base
2f1d381d 43 representation. Convert VAL, a list of digits, into an integer."
fe5fb85a
MW
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)))
48
49(defun to-mixed-base (base val)
50 "BASE is a list of the ranges for the `digits' of a mixed-base
2f1d381d 51 representation. Convert VAL, an integer, into a list of digits."
fe5fb85a
MW
52 (let ((base (reverse base))
53 (a nil))
54 (loop
55 (unless base
56 (push val a)
57 (return a))
58 (multiple-value-bind (q r) (floor val (pop base))
59 (push r a)
60 (setf val q)))))
61
afa2e2f1 62(export 'timespec-seconds)
fe5fb85a
MW
63(defun timespec-seconds (ts)
64 "Convert a timespec TS to seconds. A timespec may be a real count of
2f1d381d
MW
65 seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious
66 time units."
fe5fb85a
MW
67 (cond ((null ts) 0)
68 ((realp ts) (floor ts))
69 ((atom ts)
70 (error "Unknown timespec format ~A" ts))
71 ((null (cdr ts))
72 (timespec-seconds (car ts)))
73 (t (+ (to-integer (* (car ts)
74 (case (intern (string-upcase
75 (stringify (cadr ts)))
76 '#:zone)
77 ((s sec secs second seconds) 1)
78 ((m min mins minute minutes) 60)
79 ((h hr hrs hour hours) #.(* 60 60))
80 ((d dy dys day days) #.(* 24 60 60))
81 ((w wk wks week weeks) #.(* 7 24 60 60))
82 ((y yr yrs year years) #.(* 365 24 60 60))
83 (t (error "Unknown time unit ~A"
84 (cadr ts))))))
85 (timespec-seconds (cddr ts))))))
86
87(defun hash-table-keys (ht)
88 "Return a list of the keys in hashtable HT."
89 (collecting ()
90 (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
91
92(defun iso-date (&optional time &key datep timep (sep #\ ))
93 "Construct a textual date or time in ISO format. The TIME is the universal
2f1d381d
MW
94 time to convert, which defaults to now; DATEP is whether to emit the date;
95 TIMEP is whether to emit the time, and SEP (default is space) is how to
96 separate the two."
fe5fb85a
MW
97 (multiple-value-bind
98 (sec min hr day mon yr dow dstp tz)
99 (decode-universal-time (if (or (null time) (eq time :now))
100 (get-universal-time)
101 time))
102 (declare (ignore dow dstp tz))
103 (with-output-to-string (s)
104 (when datep
105 (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
106 (when timep
107 (write-char sep s)))
108 (when timep
109 (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
110
fe5fb85a
MW
111;;;--------------------------------------------------------------------------
112;;; Zone types.
7e282fb5 113
afa2e2f1 114(export 'soa)
7e282fb5 115(defstruct (soa (:predicate soap))
116 "Start-of-authority record information."
117 source
118 admin
119 refresh
120 retry
121 expire
122 min-ttl
123 serial)
fe5fb85a 124
afa2e2f1 125(export 'mx)
7e282fb5 126(defstruct (mx (:predicate mxp))
127 "Mail-exchange record information."
128 priority
129 domain)
fe5fb85a 130
afa2e2f1 131(export 'zone)
7e282fb5 132(defstruct (zone (:predicate zonep))
133 "Zone information."
134 soa
135 default-ttl
136 name
137 records)
138
fe5fb85a
MW
139;;;--------------------------------------------------------------------------
140;;; Zone defaults. It is intended that scripts override these.
141
afa2e2f1 142(export '*default-zone-source*)
7e282fb5 143(defvar *default-zone-source*
8e7c1366 144 (let ((hn (gethostname)))
8a4f9a18 145 (and hn (concatenate 'string (canonify-hostname hn) ".")))
7e282fb5 146 "The default zone source: the current host's name.")
fe5fb85a 147
afa2e2f1 148(export '*default-zone-refresh*)
7e282fb5 149(defvar *default-zone-refresh* (* 24 60 60)
150 "Default zone refresh interval: one day.")
fe5fb85a 151
afa2e2f1 152(export '*default-zone-admin*)
7e282fb5 153(defvar *default-zone-admin* nil
154 "Default zone administrator's email address.")
fe5fb85a 155
afa2e2f1 156(export '*default-zone-retry*)
7e282fb5 157(defvar *default-zone-retry* (* 60 60)
158 "Default znoe retry interval: one hour.")
fe5fb85a 159
afa2e2f1 160(export '*default-zone-expire*)
7e282fb5 161(defvar *default-zone-expire* (* 14 24 60 60)
162 "Default zone expiry time: two weeks.")
fe5fb85a 163
afa2e2f1 164(export '*default-zone-min-ttl*)
7e282fb5 165(defvar *default-zone-min-ttl* (* 4 60 60)
166 "Default zone minimum TTL/negative TTL: four hours.")
fe5fb85a 167
afa2e2f1 168(export '*default-zone-ttl*)
7e282fb5 169(defvar *default-zone-ttl* (* 8 60 60)
170 "Default zone TTL (for records without explicit TTLs): 8 hours.")
fe5fb85a 171
afa2e2f1 172(export '*default-mx-priority*)
7e282fb5 173(defvar *default-mx-priority* 50
174 "Default MX priority.")
175
fe5fb85a 176;;;--------------------------------------------------------------------------
fe5fb85a
MW
177;;; Zone variables and structures.
178
7e282fb5 179(defvar *zones* (make-hash-table :test #'equal)
180 "Map of known zones.")
fe5fb85a 181
afa2e2f1 182(export 'zone-find)
7e282fb5 183(defun zone-find (name)
184 "Find a zone given its NAME."
185 (gethash (string-downcase (stringify name)) *zones*))
186(defun (setf zone-find) (zone name)
187 "Make the zone NAME map to ZONE."
188 (setf (gethash (string-downcase (stringify name)) *zones*) zone))
189
afa2e2f1 190(export 'zone-record)
7e282fb5 191(defstruct (zone-record (:conc-name zr-))
192 "A zone record."
193 (name '<unnamed>)
194 ttl
195 type
590ad961 196 (make-ptr-p nil)
7e282fb5 197 data)
198
afa2e2f1 199(export 'zone-subdomain)
7e282fb5 200(defstruct (zone-subdomain (:conc-name zs-))
201 "A subdomain. Slightly weird. Used internally by zone-process-records
2f1d381d 202 below, and shouldn't escape."
7e282fb5 203 name
204 ttl
205 records)
206
afa2e2f1 207(export '*zone-output-path*)
ab87c7bf
MW
208(defvar *zone-output-path* *default-pathname-defaults*
209 "Pathname defaults to merge into output files.")
210
afa2e2f1 211(export '*preferred-subnets*)
8ce7eb9b
MW
212(defvar *preferred-subnets* nil
213 "Subnets to prefer when selecting defaults.")
214
fe5fb85a
MW
215;;;--------------------------------------------------------------------------
216;;; Zone infrastructure.
217
ab87c7bf
MW
218(defun zone-file-name (zone type)
219 "Choose a file name for a given ZONE and TYPE."
220 (merge-pathnames (make-pathname :name (string-downcase zone)
221 :type (string-downcase type))
222 *zone-output-path*))
223
afa2e2f1 224(export 'zone-preferred-subnet-p)
8ce7eb9b
MW
225(defun zone-preferred-subnet-p (name)
226 "Answer whether NAME (a string or symbol) names a preferred subnet."
227 (member name *preferred-subnets* :test #'string-equal))
228
afa2e2f1 229(export 'preferred-subnet-case)
8bd2576e
MW
230(defmacro preferred-subnet-case (&body clauses)
231 "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose
232 SUBNETS (a list or single symbol, not evaluated) are considered preferred
233 by zone-preferred-subnet-p. If SUBNETS is the symbol t then the clause
234 always matches."
235 `(cond
236 ,@(mapcar (lambda (clause)
237 (let ((subnets (car clause)))
238 (cons (cond ((eq subnets t)
239 t)
240 ((listp subnets)
241 `(or ,@(mapcar (lambda (subnet)
242 `(zone-preferred-subnet-p
243 ',subnet))
244 subnets)))
245 (t
246 `(zone-preferred-subnet-p ',subnets)))
247 (cdr clause))))
248 clauses)))
249
7e282fb5 250(defun zone-process-records (rec ttl func)
251 "Sort out the list of records in REC, calling FUNC for each one. TTL is
2f1d381d 252 the default time-to-live for records which don't specify one."
7e282fb5 253 (labels ((sift (rec ttl)
254 (collecting (top sub)
255 (loop
256 (unless rec
257 (return))
258 (let ((r (pop rec)))
259 (cond ((eq r :ttl)
260 (setf ttl (pop rec)))
261 ((symbolp r)
262 (collect (make-zone-record :type r
263 :ttl ttl
264 :data (pop rec))
265 top))
266 ((listp r)
267 (dolist (name (listify (car r)))
268 (collect (make-zone-subdomain :name name
269 :ttl ttl
270 :records (cdr r))
271 sub)))
272 (t
273 (error "Unexpected record form ~A" (car r))))))))
4e7e3780 274 (process (rec dom ttl)
7e282fb5 275 (multiple-value-bind (top sub) (sift rec ttl)
276 (if (and dom (null top) sub)
8ce7eb9b
MW
277 (let ((preferred nil))
278 (dolist (s sub)
279 (when (some #'zone-preferred-subnet-p
280 (listify (zs-name s)))
281 (setf preferred s)))
282 (unless preferred
283 (setf preferred (car sub)))
284 (when preferred
285 (process (zs-records preferred)
286 dom
287 (zs-ttl preferred))))
288 (let ((name (and dom
289 (string-downcase
290 (join-strings #\. (reverse dom))))))
291 (dolist (zr top)
292 (setf (zr-name zr) name)
293 (funcall func zr))))
7e282fb5 294 (dolist (s sub)
295 (process (zs-records s)
296 (cons (zs-name s) dom)
4e7e3780
MW
297 (zs-ttl s))))))
298 (process rec nil ttl)))
7e282fb5 299
afa2e2f1 300(export 'zone-parse-host)
7e282fb5 301(defun zone-parse-host (f zname)
302 "Parse a host name F: if F ends in a dot then it's considered absolute;
2f1d381d 303 otherwise it's relative to ZNAME."
7e282fb5 304 (setf f (stringify f))
305 (cond ((string= f "@") (stringify zname))
306 ((and (plusp (length f))
307 (char= (char f (1- (length f))) #\.))
308 (string-downcase (subseq f 0 (1- (length f)))))
309 (t (string-downcase (concatenate 'string f "."
310 (stringify zname))))))
7e282fb5 311(defun default-rev-zone (base bytes)
fe5fb85a 312 "Return the default reverse-zone name for the given BASE address and number
2f1d381d 313 of fixed leading BYTES."
7e282fb5 314 (join-strings #\. (collecting ()
315 (loop for i from (- 3 bytes) downto 0
316 do (collect (ipaddr-byte base i)))
317 (collect "in-addr.arpa"))))
318
319(defun zone-name-from-net (net &optional bytes)
320 "Given a NET, and maybe the BYTES to use, convert to the appropriate
2f1d381d 321 subdomain of in-addr.arpa."
7e282fb5 322 (let ((ipn (net-get-as-ipnet net)))
323 (with-ipnet (net mask) ipn
324 (unless bytes
325 (setf bytes (- 4 (ipnet-changeable-bytes mask))))
326 (join-strings #\.
327 (append (loop
328 for i from (- 4 bytes) below 4
329 collect (logand #xff (ash net (* -8 i))))
330 (list "in-addr.arpa"))))))
fe5fb85a 331
7e282fb5 332(defun zone-net-from-name (name)
333 "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
334 (let* ((name (string-downcase (stringify name)))
335 (len (length name))
336 (suffix ".in-addr.arpa")
337 (sufflen (length suffix))
338 (addr 0)
339 (n 0)
340 (end (- len sufflen)))
341 (unless (and (> len sufflen)
342 (string= name suffix :start1 end))
343 (error "`~A' not in ~A." name suffix))
344 (loop
345 with start = 0
346 for dot = (position #\. name :start start :end end)
347 for byte = (parse-integer name
348 :start start
349 :end (or dot end))
350 do (setf addr (logior addr (ash byte (* 8 n))))
351 (incf n)
352 when (>= n 4)
353 do (error "Can't deduce network from ~A." name)
354 while dot
355 do (setf start (1+ dot)))
356 (setf addr (ash addr (* 8 (- 4 n))))
357 (make-ipnet addr (* 8 n))))
358
7e282fb5 359(defun zone-parse-net (net name)
2f1d381d
MW
360 "Given a NET, and the NAME of a domain to guess from if NET is null, return
361 the ipnet for the network."
7e282fb5 362 (if net
363 (net-get-as-ipnet net)
364 (zone-net-from-name name)))
365
366(defun zone-cidr-delg-default-name (ipn bytes)
367 "Given a delegated net IPN and the parent's number of changing BYTES,
2f1d381d 368 return the default deletate zone prefix."
7e282fb5 369 (with-ipnet (net mask) ipn
370 (join-strings #\.
371 (reverse
372 (loop
373 for i from (1- bytes) downto 0
374 until (zerop (logand mask (ash #xff (* 8 i))))
375 collect (logand #xff (ash net (* -8 i))))))))
376
fe5fb85a 377;;;--------------------------------------------------------------------------
ab87c7bf
MW
378;;; Serial numbering.
379
afa2e2f1 380(export 'make-zone-serial)
ab87c7bf
MW
381(defun make-zone-serial (name)
382 "Given a zone NAME, come up with a new serial number. This will (very
383 carefully) update a file ZONE.serial in the current directory."
384 (let* ((file (zone-file-name name :serial))
385 (last (with-open-file (in file
386 :direction :input
387 :if-does-not-exist nil)
388 (if in (read in)
389 (list 0 0 0 0))))
390 (now (multiple-value-bind
391 (sec min hr dy mon yr dow dstp tz)
392 (get-decoded-time)
393 (declare (ignore sec min hr dow dstp tz))
394 (list dy mon yr)))
395 (seq (cond ((not (equal now (cdr last))) 0)
396 ((< (car last) 99) (1+ (car last)))
397 (t (error "Run out of sequence numbers for ~A" name)))))
398 (safely-writing (out file)
399 (format out
400 ";; Serial number file for zone ~A~%~
401 ;; (LAST-SEQ DAY MONTH YEAR)~%~
402 ~S~%"
403 name
404 (cons seq now)))
405 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
406
407;;;--------------------------------------------------------------------------
fe5fb85a 408;;; Zone form parsing.
7e282fb5 409
410(defun zone-parse-head (head)
411 "Parse the HEAD of a zone form. This has the form
412
413 (NAME &key :source :admin :refresh :retry
414 :expire :min-ttl :ttl :serial)
415
2f1d381d
MW
416 though a singleton NAME needn't be a list. Returns the default TTL and an
417 soa structure representing the zone head."
7e282fb5 418 (destructuring-bind
419 (zname
420 &key
8a4f9a18 421 (source *default-zone-source*)
7e282fb5 422 (admin (or *default-zone-admin*
423 (format nil "hostmaster@~A" zname)))
424 (refresh *default-zone-refresh*)
425 (retry *default-zone-retry*)
426 (expire *default-zone-expire*)
427 (min-ttl *default-zone-min-ttl*)
428 (ttl min-ttl)
429 (serial (make-zone-serial zname)))
430 (listify head)
431 (values zname
432 (timespec-seconds ttl)
433 (make-soa :admin admin
434 :source (zone-parse-host source zname)
435 :refresh (timespec-seconds refresh)
436 :retry (timespec-seconds retry)
437 :expire (timespec-seconds expire)
438 :min-ttl (timespec-seconds min-ttl)
439 :serial serial))))
440
afa2e2f1 441(export 'zone-make-name)
5bf80328
MW
442(defun zone-make-name (prefix zone-name)
443 (if (or (not prefix) (string= prefix "@"))
444 zone-name
445 (let ((len (length prefix)))
446 (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
447 (join-strings #\. (list prefix zone-name))
448 prefix))))
449
afa2e2f1 450(export 'defzoneparse)
7e282fb5 451(defmacro defzoneparse (types (name data list
5bf80328
MW
452 &key (prefix (gensym "PREFIX"))
453 (zname (gensym "ZNAME"))
4e7e3780 454 (ttl (gensym "TTL")))
7e282fb5 455 &body body)
fe5fb85a 456 "Define a new zone record type (or TYPES -- a list of synonyms is
2f1d381d 457 permitted). The arguments are as follows:
fe5fb85a 458
2f1d381d 459 NAME The name of the record to be added.
fe5fb85a 460
2f1d381d 461 DATA The content of the record to be added (a single object,
7fff3797 462 unevaluated).
fe5fb85a 463
2f1d381d 464 LIST A function to add a record to the zone. See below.
fe5fb85a 465
5bf80328
MW
466 PREFIX The prefix tag used in the original form.
467
2f1d381d 468 ZNAME The name of the zone being constructed.
fe5fb85a 469
2f1d381d 470 TTL The TTL for this record.
fe5fb85a 471
5bf80328
MW
472 You get to choose your own names for these. ZNAME, PREFIX and TTL are
473 optional: you don't have to accept them if you're not interested.
fe5fb85a 474
2f1d381d
MW
475 The LIST argument names a function to be bound in the body to add a new
476 low-level record to the zone. It has the prototype
fe5fb85a 477
590ad961 478 (LIST &key :name :type :data :ttl :make-ptr-p)
fe5fb85a 479
590ad961
MW
480 These (except MAKE-PTR-P, which defaults to nil) default to the above
481 arguments (even if you didn't accept the arguments)."
7e282fb5 482 (setf types (listify types))
483 (let* ((type (car types))
484 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
2ec279f5 485 (with-parsed-body (body decls doc) body
590ad961 486 (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
40ded1b8
MW
487 `(progn
488 (dolist (,i ',types)
489 (setf (get ,i 'zone-parse) ',func))
5bf80328 490 (defun ,func (,prefix ,zname ,data ,ttl ,col)
40ded1b8
MW
491 ,@doc
492 ,@decls
5bf80328
MW
493 (let ((,name (zone-make-name ,prefix ,zname)))
494 (flet ((,list (&key ((:name ,tname) ,name)
495 ((:type ,ttype) ,type)
496 ((:data ,tdata) ,data)
590ad961
MW
497 ((:ttl ,tttl) ,ttl)
498 ((:make-ptr-p ,tmakeptrp) nil))
f4decf40 499 #+cmu (declare (optimize ext:inhibit-warnings))
5bf80328
MW
500 (collect (make-zone-record :name ,tname
501 :type ,ttype
502 :data ,tdata
590ad961
MW
503 :ttl ,tttl
504 :make-ptr-p ,tmakeptrp)
5bf80328
MW
505 ,col)))
506 ,@body)))
507 ',type)))))
7e282fb5 508
509(defun zone-parse-records (zone records)
510 (let ((zname (zone-name zone)))
511 (with-collection (rec)
512 (flet ((parse-record (zr)
513 (let ((func (or (get (zr-type zr) 'zone-parse)
514 (error "No parser for record ~A."
515 (zr-type zr))))
5bf80328 516 (name (and (zr-name zr) (stringify (zr-name zr)))))
7e282fb5 517 (funcall func
518 name
5bf80328 519 zname
7e282fb5 520 (zr-data zr)
521 (zr-ttl zr)
5bf80328 522 rec))))
7e282fb5 523 (zone-process-records records
524 (zone-default-ttl zone)
7fff3797 525 #'parse-record))
7e282fb5 526 (setf (zone-records zone) (nconc (zone-records zone) rec)))))
527
afa2e2f1 528(export 'zone-parse)
7e282fb5 529(defun zone-parse (zf)
530 "Parse a ZONE form. The syntax of a zone form is as follows:
531
2f1d381d
MW
532 ZONE-FORM:
533 ZONE-HEAD ZONE-RECORD*
7e282fb5 534
2f1d381d
MW
535 ZONE-RECORD:
536 ((NAME*) ZONE-RECORD*)
537 | SYM ARGS"
7e282fb5 538 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
539 (let ((zone (make-zone :name zname
540 :default-ttl ttl
541 :soa soa
542 :records nil)))
543 (zone-parse-records zone (cdr zf))
544 zone)))
545
afa2e2f1 546(export 'zone-create)
fe5fb85a
MW
547(defun zone-create (zf)
548 "Zone construction function. Given a zone form ZF, construct the zone and
2f1d381d 549 add it to the table."
fe5fb85a
MW
550 (let* ((zone (zone-parse zf))
551 (name (zone-name zone)))
552 (setf (zone-find name) zone)
553 name))
554
afa2e2f1 555(export 'defzone)
fe5fb85a
MW
556(defmacro defzone (soa &rest zf)
557 "Zone definition macro."
558 `(zone-create '(,soa ,@zf)))
559
afa2e2f1 560(export 'defrevzone)
fe5fb85a
MW
561(defmacro defrevzone (head &rest zf)
562 "Define a reverse zone, with the correct name."
563 (destructuring-bind
564 (net &rest soa-args)
565 (listify head)
566 (let ((bytes nil))
567 (when (and soa-args (integerp (car soa-args)))
568 (setf bytes (pop soa-args)))
569 `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
570
571;;;--------------------------------------------------------------------------
572;;; Zone record parsers.
573
4e7e3780 574(defzoneparse :a (name data rec)
7e282fb5 575 ":a IPADDR"
590ad961
MW
576 (rec :data (parse-ipaddr data) :make-ptr-p t))
577
578(defzoneparse :svc (name data rec)
579 ":svc IPADDR"
580 (rec :type :a :data (parse-ipaddr data)))
fe5fb85a 581
7e282fb5 582(defzoneparse :ptr (name data rec :zname zname)
583 ":ptr HOST"
584 (rec :data (zone-parse-host data zname)))
fe5fb85a 585
7e282fb5 586(defzoneparse :cname (name data rec :zname zname)
587 ":cname HOST"
588 (rec :data (zone-parse-host data zname)))
fe5fb85a 589
90022a23
MW
590(defzoneparse :txt (name data rec)
591 ":txt TEXT"
592 (rec :data data))
593
7e282fb5 594(defzoneparse :mx (name data rec :zname zname)
595 ":mx ((HOST :prio INT :ip IPADDR)*)"
596 (dolist (mx (listify data))
597 (destructuring-bind
598 (mxname &key (prio *default-mx-priority*) ip)
599 (listify mx)
600 (let ((host (zone-parse-host mxname zname)))
601 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
602 (rec :data (cons host prio))))))
fe5fb85a 603
7e282fb5 604(defzoneparse :ns (name data rec :zname zname)
605 ":ns ((HOST :ip IPADDR)*)"
606 (dolist (ns (listify data))
607 (destructuring-bind
608 (nsname &key ip)
609 (listify ns)
610 (let ((host (zone-parse-host nsname zname)))
611 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
612 (rec :data host)))))
fe5fb85a 613
7e282fb5 614(defzoneparse :alias (name data rec :zname zname)
615 ":alias (LABEL*)"
616 (dolist (a (listify data))
617 (rec :name (zone-parse-host a zname)
618 :type :cname
619 :data name)))
fe5fb85a 620
716105aa
MW
621(defzoneparse :srv (name data rec :zname zname)
622 ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
623 (dolist (srv data)
624 (destructuring-bind (servopts &rest providers) srv
625 (destructuring-bind
626 (service &key ((:port default-port)) (protocol :tcp))
627 (listify servopts)
628 (unless default-port
629 (let ((serv (serv-by-name service protocol)))
630 (setf default-port (and serv (serv-port serv)))))
631 (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
632 (dolist (prov providers)
633 (destructuring-bind
634 (srvname
635 &key
636 (port default-port)
637 (prio *default-mx-priority*)
638 (weight 0)
639 ip)
640 (listify prov)
641 (let ((host (zone-parse-host srvname zname)))
642 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
643 (rec :name rname
644 :data (list prio weight port host))))))))))
645
a15288b4 646(defzoneparse :net (name data rec)
647 ":net (NETWORK*)"
648 (dolist (net (listify data))
649 (let ((n (net-get-as-ipnet net)))
650 (rec :name (zone-parse-host "net" name)
651 :type :a
652 :data (ipnet-net n))
653 (rec :name (zone-parse-host "mask" name)
654 :type :a
655 :data (ipnet-mask n))
656 (rec :name (zone-parse-host "broadcast" name)
657 :type :a
658 :data (ipnet-broadcast n)))))
7fff3797 659
7e282fb5 660(defzoneparse (:rev :reverse) (name data rec)
679775ba
MW
661 ":reverse ((NET :bytes BYTES) ZONE*)
662
663 Add a reverse record each host in the ZONEs (or all zones) that lies
664 within NET. The BYTES give the number of prefix labels generated; this
665 defaults to the smallest number of bytes needed to enumerate the net."
7e282fb5 666 (setf data (listify data))
cc0fa47a 667 (destructuring-bind (net &key bytes) (listify (car data))
7e282fb5 668 (setf net (zone-parse-net net name))
669 (unless bytes
670 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
4e7e3780
MW
671 (let ((seen (make-hash-table :test #'equal)))
672 (dolist (z (or (cdr data)
673 (hash-table-keys *zones*)))
674 (dolist (zr (zone-records (zone-find z)))
675 (when (and (eq (zr-type zr) :a)
590ad961 676 (zr-make-ptr-p zr)
4e7e3780
MW
677 (ipaddr-networkp (zr-data zr) net))
678 (let ((name (string-downcase
679 (join-strings
680 #\.
681 (collecting ()
682 (dotimes (i bytes)
683 (collect (logand #xff (ash (zr-data zr)
684 (* -8 i)))))
685 (collect name))))))
686 (unless (gethash name seen)
687 (rec :name name :type :ptr
688 :ttl (zr-ttl zr) :data (zr-name zr))
689 (setf (gethash name seen) t)))))))))
7e282fb5 690
cc0fa47a 691(defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
679775ba
MW
692 ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*)
693
694 Insert CNAME records for delegating a portion of the reverse-lookup
695 namespace which doesn't align with an octet boundary.
696
697 The NET specifies the origin network, in which the reverse records
698 naturally lie. The BYTES are the number of labels to supply for each
699 address; the default is the smallest number which suffices to enumerate
700 the entire NET. The TARGET-NETs are subnets of NET which are to be
701 delegated. The TARGET-ZONEs are the zones to which we are delegating
702 authority for the reverse records: the default is to append labels for those
703 octets of the subnet base address which are not the same in all address in
704 the subnet."
cc0fa47a
MW
705 (setf data (listify data))
706 (destructuring-bind (net &key bytes) (listify (car data))
7e282fb5 707 (setf net (zone-parse-net net name))
708 (unless bytes
709 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
cc0fa47a
MW
710 (dolist (map (or (cdr data) (list (list net))))
711 (destructuring-bind (tnet &optional tdom) (listify map)
7e282fb5 712 (setf tnet (zone-parse-net tnet name))
713 (unless (ipnet-subnetp net tnet)
714 (error "~A is not a subnet of ~A."
715 (ipnet-pretty tnet)
7fff3797 716 (ipnet-pretty net)))
7e282fb5 717 (unless tdom
718 (with-ipnet (net mask) tnet
719 (setf tdom
720 (join-strings
721 #\.
722 (append (reverse (loop
cc0fa47a
MW
723 for i from (1- bytes) downto 0
724 until (zerop (logand mask
725 (ash #xff
726 (* 8 i))))
727 collect (ldb (byte 8 (* i 8)) net)))
7e282fb5 728 (list name))))))
cc0fa47a 729 (setf tdom (string-downcase (stringify tdom)))
7e282fb5 730 (dotimes (i (ipnet-hosts tnet))
cc0fa47a
MW
731 (unless (zerop i)
732 (let* ((addr (ipnet-host tnet i))
733 (tail (join-strings #\.
734 (loop
7e282fb5 735 for i from 0 below bytes
736 collect
cc0fa47a
MW
737 (logand #xff
738 (ash addr (* 8 i)))))))
739 (rec :name (format nil "~A.~A" tail name)
740 :type :cname
741 :data (format nil "~A.~A" tail tdom)))))))))
7e282fb5 742
fe5fb85a
MW
743;;;--------------------------------------------------------------------------
744;;; Zone file output.
7e282fb5 745
afa2e2f1 746(export 'zone-write)
a567a3bc
MW
747(defgeneric zone-write (format zone stream)
748 (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
749
750(defvar *writing-zone* nil
751 "The zone currently being written.")
752
753(defvar *zone-output-stream* nil
754 "Stream to write zone data on.")
755
756(defmethod zone-write :around (format zone stream)
757 (let ((*writing-zone* zone)
758 (*zone-output-stream* stream))
759 (call-next-method)))
760
afa2e2f1 761(export 'zone-save)
a567a3bc
MW
762(defun zone-save (zones &key (format :bind))
763 "Write the named ZONES to files. If no zones are given, write all the
764 zones."
765 (unless zones
766 (setf zones (hash-table-keys *zones*)))
767 (safely (safe)
768 (dolist (z zones)
769 (let ((zz (zone-find z)))
770 (unless zz
771 (error "Unknown zone `~A'." z))
772 (let ((stream (safely-open-output-stream safe
773 (zone-file-name z :zone))))
774 (zone-write format zz stream))))))
775
776;;;--------------------------------------------------------------------------
777;;; Bind format output.
778
afa2e2f1 779(export 'bind-hostname)
a567a3bc
MW
780(defun bind-hostname (hostname)
781 (if (not hostname)
782 "@"
783 (let* ((h (string-downcase (stringify hostname)))
784 (hl (length h))
785 (r (string-downcase (zone-name *writing-zone*)))
786 (rl (length r)))
787 (cond ((string= r h) "@")
788 ((and (> hl rl)
789 (char= (char h (- hl rl 1)) #\.)
790 (string= h r :start1 (- hl rl)))
791 (subseq h 0 (- hl rl 1)))
792 (t (concatenate 'string h "."))))))
793
794(defmethod zone-write ((format (eql :bind)) zone stream)
795 (format stream "~
7e282fb5 796;;; Zone file `~(~A~)'
797;;; (generated ~A)
798
7d593efd
MW
799$ORIGIN ~0@*~(~A.~)
800$TTL ~2@*~D~2%"
7e282fb5 801 (zone-name zone)
802 (iso-date :now :datep t :timep t)
803 (zone-default-ttl zone))
a567a3bc
MW
804 (let* ((soa (zone-soa zone))
805 (admin (let* ((name (soa-admin soa))
806 (at (position #\@ name))
807 (copy (format nil "~(~A~)." name)))
808 (when at
809 (setf (char copy at) #\.))
810 copy)))
7e282fb5 811 (format stream "~
812~A~30TIN SOA~40T~A ~A (
813~45T~10D~60T ;serial
814~45T~10D~60T ;refresh
815~45T~10D~60T ;retry
816~45T~10D~60T ;expire
817~45T~10D )~60T ;min-ttl~2%"
a567a3bc
MW
818 (bind-hostname (zone-name zone))
819 (bind-hostname (soa-source soa))
820 admin
7e282fb5 821 (soa-serial soa)
822 (soa-refresh soa)
823 (soa-retry soa)
824 (soa-expire soa)
825 (soa-min-ttl soa)))
a567a3bc
MW
826 (dolist (zr (zone-records zone))
827 (bind-record (zr-type zr) zr)))
828
afa2e2f1 829(export 'bind-record)
a567a3bc
MW
830(defgeneric bind-record (type zr))
831
afa2e2f1 832(export 'bind-format-record)
a567a3bc
MW
833(defun bind-format-record (name ttl type format args)
834 (format *zone-output-stream*
835 "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
836 (bind-hostname name)
837 (and (/= ttl (zone-default-ttl *writing-zone*))
838 ttl)
839 (string-upcase (symbol-name type))
840 format args))
841
842(defmethod bind-record (type zr)
843 (destructuring-bind (format &rest args)
844 (bind-record-format-args type (zr-data zr))
845 (bind-format-record (zr-name zr)
846 (zr-ttl zr)
847 (bind-record-type type)
848 format args)))
849
afa2e2f1 850(export 'bind-record-type)
a567a3bc
MW
851(defgeneric bind-record-type (type)
852 (:method (type) type))
853
afa2e2f1 854(export 'bind-record-format-args)
a567a3bc
MW
855(defgeneric bind-record-format-args (type data)
856 (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
857 (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
858 (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
859 (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
860 (:method ((type (eql :mx)) data)
861 (list "~2D ~A" (cdr data) (bind-hostname (car data))))
716105aa
MW
862 (:method ((type (eql :srv)) data)
863 (destructuring-bind (prio weight port host) data
864 (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
a567a3bc 865 (:method ((type (eql :txt)) data) (list "~S" (stringify data))))
7e282fb5 866
867;;;----- That's all, folks --------------------------------------------------