chiark / gitweb /
zone.lisp: Clean up whitespace.
[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)
64e34a97
MW
277 (let ((preferred
278 (or (find-if (lambda (s)
279 (some #'zone-preferred-subnet-p
280 (listify (zs-name s))))
281 sub)
282 (car sub))))
8ce7eb9b
MW
283 (when preferred
284 (process (zs-records preferred)
285 dom
286 (zs-ttl preferred))))
287 (let ((name (and dom
288 (string-downcase
289 (join-strings #\. (reverse dom))))))
290 (dolist (zr top)
291 (setf (zr-name zr) name)
292 (funcall func zr))))
7e282fb5 293 (dolist (s sub)
294 (process (zs-records s)
295 (cons (zs-name s) dom)
4e7e3780
MW
296 (zs-ttl s))))))
297 (process rec nil ttl)))
7e282fb5 298
afa2e2f1 299(export 'zone-parse-host)
7e282fb5 300(defun zone-parse-host (f zname)
301 "Parse a host name F: if F ends in a dot then it's considered absolute;
2f1d381d 302 otherwise it's relative to ZNAME."
7e282fb5 303 (setf f (stringify f))
304 (cond ((string= f "@") (stringify zname))
305 ((and (plusp (length f))
306 (char= (char f (1- (length f))) #\.))
307 (string-downcase (subseq f 0 (1- (length f)))))
308 (t (string-downcase (concatenate 'string f "."
309 (stringify zname))))))
7e282fb5 310(defun default-rev-zone (base bytes)
fe5fb85a 311 "Return the default reverse-zone name for the given BASE address and number
2f1d381d 312 of fixed leading BYTES."
7e282fb5 313 (join-strings #\. (collecting ()
314 (loop for i from (- 3 bytes) downto 0
315 do (collect (ipaddr-byte base i)))
316 (collect "in-addr.arpa"))))
317
318(defun zone-name-from-net (net &optional bytes)
319 "Given a NET, and maybe the BYTES to use, convert to the appropriate
2f1d381d 320 subdomain of in-addr.arpa."
7e282fb5 321 (let ((ipn (net-get-as-ipnet net)))
322 (with-ipnet (net mask) ipn
323 (unless bytes
324 (setf bytes (- 4 (ipnet-changeable-bytes mask))))
325 (join-strings #\.
326 (append (loop
327 for i from (- 4 bytes) below 4
328 collect (logand #xff (ash net (* -8 i))))
329 (list "in-addr.arpa"))))))
fe5fb85a 330
7e282fb5 331(defun zone-net-from-name (name)
332 "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
333 (let* ((name (string-downcase (stringify name)))
334 (len (length name))
335 (suffix ".in-addr.arpa")
336 (sufflen (length suffix))
337 (addr 0)
338 (n 0)
339 (end (- len sufflen)))
340 (unless (and (> len sufflen)
341 (string= name suffix :start1 end))
342 (error "`~A' not in ~A." name suffix))
343 (loop
344 with start = 0
345 for dot = (position #\. name :start start :end end)
346 for byte = (parse-integer name
347 :start start
348 :end (or dot end))
349 do (setf addr (logior addr (ash byte (* 8 n))))
350 (incf n)
351 when (>= n 4)
352 do (error "Can't deduce network from ~A." name)
353 while dot
354 do (setf start (1+ dot)))
355 (setf addr (ash addr (* 8 (- 4 n))))
356 (make-ipnet addr (* 8 n))))
357
7e282fb5 358(defun zone-parse-net (net name)
2f1d381d
MW
359 "Given a NET, and the NAME of a domain to guess from if NET is null, return
360 the ipnet for the network."
7e282fb5 361 (if net
362 (net-get-as-ipnet net)
363 (zone-net-from-name name)))
364
365(defun zone-cidr-delg-default-name (ipn bytes)
366 "Given a delegated net IPN and the parent's number of changing BYTES,
2f1d381d 367 return the default deletate zone prefix."
7e282fb5 368 (with-ipnet (net mask) ipn
369 (join-strings #\.
370 (reverse
371 (loop
372 for i from (1- bytes) downto 0
373 until (zerop (logand mask (ash #xff (* 8 i))))
374 collect (logand #xff (ash net (* -8 i))))))))
375
fe5fb85a 376;;;--------------------------------------------------------------------------
ab87c7bf
MW
377;;; Serial numbering.
378
afa2e2f1 379(export 'make-zone-serial)
ab87c7bf
MW
380(defun make-zone-serial (name)
381 "Given a zone NAME, come up with a new serial number. This will (very
382 carefully) update a file ZONE.serial in the current directory."
383 (let* ((file (zone-file-name name :serial))
384 (last (with-open-file (in file
385 :direction :input
386 :if-does-not-exist nil)
387 (if in (read in)
388 (list 0 0 0 0))))
389 (now (multiple-value-bind
390 (sec min hr dy mon yr dow dstp tz)
391 (get-decoded-time)
392 (declare (ignore sec min hr dow dstp tz))
393 (list dy mon yr)))
394 (seq (cond ((not (equal now (cdr last))) 0)
395 ((< (car last) 99) (1+ (car last)))
396 (t (error "Run out of sequence numbers for ~A" name)))))
397 (safely-writing (out file)
398 (format out
399 ";; Serial number file for zone ~A~%~
b23c65ee
MW
400 ;; (LAST-SEQ DAY MONTH YEAR)~%~
401 ~S~%"
ab87c7bf
MW
402 name
403 (cons seq now)))
404 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
405
406;;;--------------------------------------------------------------------------
fe5fb85a 407;;; Zone form parsing.
7e282fb5 408
409(defun zone-parse-head (head)
410 "Parse the HEAD of a zone form. This has the form
411
412 (NAME &key :source :admin :refresh :retry
b23c65ee 413 :expire :min-ttl :ttl :serial)
7e282fb5 414
2f1d381d
MW
415 though a singleton NAME needn't be a list. Returns the default TTL and an
416 soa structure representing the zone head."
7e282fb5 417 (destructuring-bind
418 (zname
419 &key
8a4f9a18 420 (source *default-zone-source*)
7e282fb5 421 (admin (or *default-zone-admin*
422 (format nil "hostmaster@~A" zname)))
423 (refresh *default-zone-refresh*)
424 (retry *default-zone-retry*)
425 (expire *default-zone-expire*)
426 (min-ttl *default-zone-min-ttl*)
427 (ttl min-ttl)
428 (serial (make-zone-serial zname)))
429 (listify head)
430 (values zname
431 (timespec-seconds ttl)
432 (make-soa :admin admin
433 :source (zone-parse-host source zname)
434 :refresh (timespec-seconds refresh)
435 :retry (timespec-seconds retry)
436 :expire (timespec-seconds expire)
437 :min-ttl (timespec-seconds min-ttl)
438 :serial serial))))
439
afa2e2f1 440(export 'zone-make-name)
5bf80328
MW
441(defun zone-make-name (prefix zone-name)
442 (if (or (not prefix) (string= prefix "@"))
443 zone-name
444 (let ((len (length prefix)))
445 (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
446 (join-strings #\. (list prefix zone-name))
447 prefix))))
448
afa2e2f1 449(export 'defzoneparse)
7e282fb5 450(defmacro defzoneparse (types (name data list
5bf80328 451 &key (prefix (gensym "PREFIX"))
b23c65ee
MW
452 (zname (gensym "ZNAME"))
453 (ttl (gensym "TTL")))
7e282fb5 454 &body body)
fe5fb85a 455 "Define a new zone record type (or TYPES -- a list of synonyms is
2f1d381d 456 permitted). The arguments are as follows:
fe5fb85a 457
2f1d381d 458 NAME The name of the record to be added.
fe5fb85a 459
2f1d381d 460 DATA The content of the record to be added (a single object,
7fff3797 461 unevaluated).
fe5fb85a 462
2f1d381d 463 LIST A function to add a record to the zone. See below.
fe5fb85a 464
5bf80328
MW
465 PREFIX The prefix tag used in the original form.
466
2f1d381d 467 ZNAME The name of the zone being constructed.
fe5fb85a 468
2f1d381d 469 TTL The TTL for this record.
fe5fb85a 470
5bf80328
MW
471 You get to choose your own names for these. ZNAME, PREFIX and TTL are
472 optional: you don't have to accept them if you're not interested.
fe5fb85a 473
2f1d381d
MW
474 The LIST argument names a function to be bound in the body to add a new
475 low-level record to the zone. It has the prototype
fe5fb85a 476
590ad961 477 (LIST &key :name :type :data :ttl :make-ptr-p)
fe5fb85a 478
590ad961
MW
479 These (except MAKE-PTR-P, which defaults to nil) default to the above
480 arguments (even if you didn't accept the arguments)."
7e282fb5 481 (setf types (listify types))
482 (let* ((type (car types))
483 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
2ec279f5 484 (with-parsed-body (body decls doc) body
590ad961 485 (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
40ded1b8
MW
486 `(progn
487 (dolist (,i ',types)
488 (setf (get ,i 'zone-parse) ',func))
5bf80328 489 (defun ,func (,prefix ,zname ,data ,ttl ,col)
40ded1b8
MW
490 ,@doc
491 ,@decls
5bf80328
MW
492 (let ((,name (zone-make-name ,prefix ,zname)))
493 (flet ((,list (&key ((:name ,tname) ,name)
494 ((:type ,ttype) ,type)
495 ((:data ,tdata) ,data)
590ad961
MW
496 ((:ttl ,tttl) ,ttl)
497 ((:make-ptr-p ,tmakeptrp) nil))
f4decf40 498 #+cmu (declare (optimize ext:inhibit-warnings))
5bf80328
MW
499 (collect (make-zone-record :name ,tname
500 :type ,ttype
501 :data ,tdata
590ad961
MW
502 :ttl ,tttl
503 :make-ptr-p ,tmakeptrp)
5bf80328
MW
504 ,col)))
505 ,@body)))
506 ',type)))))
7e282fb5 507
508(defun zone-parse-records (zone records)
509 (let ((zname (zone-name zone)))
510 (with-collection (rec)
511 (flet ((parse-record (zr)
512 (let ((func (or (get (zr-type zr) 'zone-parse)
513 (error "No parser for record ~A."
514 (zr-type zr))))
5bf80328 515 (name (and (zr-name zr) (stringify (zr-name zr)))))
7e282fb5 516 (funcall func
517 name
5bf80328 518 zname
7e282fb5 519 (zr-data zr)
520 (zr-ttl zr)
5bf80328 521 rec))))
7e282fb5 522 (zone-process-records records
523 (zone-default-ttl zone)
7fff3797 524 #'parse-record))
7e282fb5 525 (setf (zone-records zone) (nconc (zone-records zone) rec)))))
526
afa2e2f1 527(export 'zone-parse)
7e282fb5 528(defun zone-parse (zf)
529 "Parse a ZONE form. The syntax of a zone form is as follows:
530
2f1d381d
MW
531 ZONE-FORM:
532 ZONE-HEAD ZONE-RECORD*
7e282fb5 533
2f1d381d
MW
534 ZONE-RECORD:
535 ((NAME*) ZONE-RECORD*)
536 | SYM ARGS"
7e282fb5 537 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
538 (let ((zone (make-zone :name zname
539 :default-ttl ttl
540 :soa soa
541 :records nil)))
542 (zone-parse-records zone (cdr zf))
543 zone)))
544
afa2e2f1 545(export 'zone-create)
fe5fb85a
MW
546(defun zone-create (zf)
547 "Zone construction function. Given a zone form ZF, construct the zone and
2f1d381d 548 add it to the table."
fe5fb85a
MW
549 (let* ((zone (zone-parse zf))
550 (name (zone-name zone)))
551 (setf (zone-find name) zone)
552 name))
553
afa2e2f1 554(export 'defzone)
fe5fb85a
MW
555(defmacro defzone (soa &rest zf)
556 "Zone definition macro."
557 `(zone-create '(,soa ,@zf)))
558
afa2e2f1 559(export 'defrevzone)
fe5fb85a
MW
560(defmacro defrevzone (head &rest zf)
561 "Define a reverse zone, with the correct name."
562 (destructuring-bind
563 (net &rest soa-args)
564 (listify head)
565 (let ((bytes nil))
566 (when (and soa-args (integerp (car soa-args)))
567 (setf bytes (pop soa-args)))
568 `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
569
570;;;--------------------------------------------------------------------------
571;;; Zone record parsers.
572
4e7e3780 573(defzoneparse :a (name data rec)
7e282fb5 574 ":a IPADDR"
590ad961
MW
575 (rec :data (parse-ipaddr data) :make-ptr-p t))
576
577(defzoneparse :svc (name data rec)
578 ":svc IPADDR"
579 (rec :type :a :data (parse-ipaddr data)))
fe5fb85a 580
7e282fb5 581(defzoneparse :ptr (name data rec :zname zname)
582 ":ptr HOST"
583 (rec :data (zone-parse-host data zname)))
fe5fb85a 584
7e282fb5 585(defzoneparse :cname (name data rec :zname zname)
586 ":cname HOST"
587 (rec :data (zone-parse-host data zname)))
fe5fb85a 588
90022a23
MW
589(defzoneparse :txt (name data rec)
590 ":txt TEXT"
591 (rec :data data))
592
7e282fb5 593(defzoneparse :mx (name data rec :zname zname)
594 ":mx ((HOST :prio INT :ip IPADDR)*)"
595 (dolist (mx (listify data))
596 (destructuring-bind
597 (mxname &key (prio *default-mx-priority*) ip)
598 (listify mx)
599 (let ((host (zone-parse-host mxname zname)))
600 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
601 (rec :data (cons host prio))))))
fe5fb85a 602
7e282fb5 603(defzoneparse :ns (name data rec :zname zname)
604 ":ns ((HOST :ip IPADDR)*)"
605 (dolist (ns (listify data))
606 (destructuring-bind
607 (nsname &key ip)
608 (listify ns)
609 (let ((host (zone-parse-host nsname zname)))
610 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
611 (rec :data host)))))
fe5fb85a 612
7e282fb5 613(defzoneparse :alias (name data rec :zname zname)
614 ":alias (LABEL*)"
615 (dolist (a (listify data))
616 (rec :name (zone-parse-host a zname)
617 :type :cname
618 :data name)))
fe5fb85a 619
716105aa
MW
620(defzoneparse :srv (name data rec :zname zname)
621 ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
622 (dolist (srv data)
623 (destructuring-bind (servopts &rest providers) srv
624 (destructuring-bind
625 (service &key ((:port default-port)) (protocol :tcp))
626 (listify servopts)
627 (unless default-port
628 (let ((serv (serv-by-name service protocol)))
629 (setf default-port (and serv (serv-port serv)))))
630 (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
631 (dolist (prov providers)
632 (destructuring-bind
633 (srvname
634 &key
635 (port default-port)
636 (prio *default-mx-priority*)
637 (weight 0)
638 ip)
639 (listify prov)
640 (let ((host (zone-parse-host srvname zname)))
641 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
642 (rec :name rname
643 :data (list prio weight port host))))))))))
644
a15288b4 645(defzoneparse :net (name data rec)
646 ":net (NETWORK*)"
647 (dolist (net (listify data))
648 (let ((n (net-get-as-ipnet net)))
649 (rec :name (zone-parse-host "net" name)
650 :type :a
651 :data (ipnet-net n))
652 (rec :name (zone-parse-host "mask" name)
653 :type :a
654 :data (ipnet-mask n))
098b57a2 655 (rec :name (zone-parse-host "bcast" name)
a15288b4 656 :type :a
657 :data (ipnet-broadcast n)))))
7fff3797 658
7e282fb5 659(defzoneparse (:rev :reverse) (name data rec)
679775ba
MW
660 ":reverse ((NET :bytes BYTES) ZONE*)
661
662 Add a reverse record each host in the ZONEs (or all zones) that lies
663 within NET. The BYTES give the number of prefix labels generated; this
664 defaults to the smallest number of bytes needed to enumerate the net."
7e282fb5 665 (setf data (listify data))
cc0fa47a 666 (destructuring-bind (net &key bytes) (listify (car data))
7e282fb5 667 (setf net (zone-parse-net net name))
668 (unless bytes
669 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
4e7e3780
MW
670 (let ((seen (make-hash-table :test #'equal)))
671 (dolist (z (or (cdr data)
672 (hash-table-keys *zones*)))
673 (dolist (zr (zone-records (zone-find z)))
674 (when (and (eq (zr-type zr) :a)
590ad961 675 (zr-make-ptr-p zr)
4e7e3780
MW
676 (ipaddr-networkp (zr-data zr) net))
677 (let ((name (string-downcase
678 (join-strings
679 #\.
680 (collecting ()
681 (dotimes (i bytes)
682 (collect (logand #xff (ash (zr-data zr)
683 (* -8 i)))))
684 (collect name))))))
685 (unless (gethash name seen)
686 (rec :name name :type :ptr
687 :ttl (zr-ttl zr) :data (zr-name zr))
688 (setf (gethash name seen) t)))))))))
7e282fb5 689
cc0fa47a 690(defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
679775ba
MW
691 ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*)
692
693 Insert CNAME records for delegating a portion of the reverse-lookup
694 namespace which doesn't align with an octet boundary.
695
696 The NET specifies the origin network, in which the reverse records
697 naturally lie. The BYTES are the number of labels to supply for each
698 address; the default is the smallest number which suffices to enumerate
699 the entire NET. The TARGET-NETs are subnets of NET which are to be
700 delegated. The TARGET-ZONEs are the zones to which we are delegating
701 authority for the reverse records: the default is to append labels for those
702 octets of the subnet base address which are not the same in all address in
703 the subnet."
cc0fa47a
MW
704 (setf data (listify data))
705 (destructuring-bind (net &key bytes) (listify (car data))
7e282fb5 706 (setf net (zone-parse-net net name))
707 (unless bytes
708 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
cc0fa47a 709 (dolist (map (or (cdr data) (list (list net))))
4440be0d
MW
710 (destructuring-bind (tnets &optional tdom) (listify map)
711 (dolist (tnet (listify tnets))
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)
716 (ipnet-pretty net)))
717 (unless tdom
718 (with-ipnet (net mask) tnet
719 (setf tdom
720 (join-strings
721 #\.
722 (append (reverse (loop
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)))
728 (list name))))))
729 (setf tdom (string-downcase (stringify tdom)))
730 (dotimes (i (ipnet-hosts tnet))
731 (unless (zerop i)
732 (let* ((addr (ipnet-host tnet i))
733 (tail (join-strings #\.
734 (loop
735 for i from 0 below bytes
736 collect
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 --------------------------------------------------