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