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