chiark / gitweb /
zone: Quench warnings from zone-parser functions.
[zone] / zone.lisp
CommitLineData
7e282fb5 1;;; -*-lisp-*-
2;;;
3;;; $Id$
4;;;
5;;; DNS zone generation
6;;;
7;;; (c) 2005 Straylight/Edgeware
8;;;
9
10;;;----- Licensing notice ---------------------------------------------------
11;;;
12;;; This program is free software; you can redistribute it and/or modify
13;;; it under the terms of the GNU General Public License as published by
14;;; the Free Software Foundation; either version 2 of the License, or
15;;; (at your option) any later version.
7fff3797 16;;;
7e282fb5 17;;; This program is distributed in the hope that it will be useful,
18;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;;; GNU General Public License for more details.
7fff3797 21;;;
7e282fb5 22;;; You should have received a copy of the GNU General Public License
23;;; along with this program; if not, write to the Free Software Foundation,
24;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
25
fe5fb85a
MW
26;;;--------------------------------------------------------------------------
27;;; Packaging.
28
7e282fb5 29(defpackage #:zone
85c39c01 30 (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net)
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
51a6847e
MW
152#+ecl
153(cffi:defcfun gethostname :int
154 (name :pointer)
155 (len :uint))
156
7e282fb5 157(defvar *default-zone-source*
7d593efd 158 (let ((hn #+cmu (unix:unix-gethostname)
51a6847e
MW
159 #+clisp (unix:get-host-name)
160 #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
161 (let ((rc (gethostname buffer len)))
162 (unless (zerop rc)
163 (error "gethostname(2) failed (rc = ~A)." rc))))))
8a4f9a18 164 (and hn (concatenate 'string (canonify-hostname hn) ".")))
7e282fb5 165 "The default zone source: the current host's name.")
fe5fb85a 166
7e282fb5 167(defvar *default-zone-refresh* (* 24 60 60)
168 "Default zone refresh interval: one day.")
fe5fb85a 169
7e282fb5 170(defvar *default-zone-admin* nil
171 "Default zone administrator's email address.")
fe5fb85a 172
7e282fb5 173(defvar *default-zone-retry* (* 60 60)
174 "Default znoe retry interval: one hour.")
fe5fb85a 175
7e282fb5 176(defvar *default-zone-expire* (* 14 24 60 60)
177 "Default zone expiry time: two weeks.")
fe5fb85a 178
7e282fb5 179(defvar *default-zone-min-ttl* (* 4 60 60)
180 "Default zone minimum TTL/negative TTL: four hours.")
fe5fb85a 181
7e282fb5 182(defvar *default-zone-ttl* (* 8 60 60)
183 "Default zone TTL (for records without explicit TTLs): 8 hours.")
fe5fb85a 184
7e282fb5 185(defvar *default-mx-priority* 50
186 "Default MX priority.")
187
fe5fb85a 188;;;--------------------------------------------------------------------------
fe5fb85a
MW
189;;; Zone variables and structures.
190
7e282fb5 191(defvar *zones* (make-hash-table :test #'equal)
192 "Map of known zones.")
fe5fb85a 193
7e282fb5 194(defun zone-find (name)
195 "Find a zone given its NAME."
196 (gethash (string-downcase (stringify name)) *zones*))
fe5fb85a 197
7e282fb5 198(defun (setf zone-find) (zone name)
199 "Make the zone NAME map to ZONE."
200 (setf (gethash (string-downcase (stringify name)) *zones*) zone))
201
202(defstruct (zone-record (:conc-name zr-))
203 "A zone record."
204 (name '<unnamed>)
205 ttl
206 type
590ad961 207 (make-ptr-p nil)
7e282fb5 208 data)
209
210(defstruct (zone-subdomain (:conc-name zs-))
211 "A subdomain. Slightly weird. Used internally by zone-process-records
2f1d381d 212 below, and shouldn't escape."
7e282fb5 213 name
214 ttl
215 records)
216
ab87c7bf
MW
217(defvar *zone-output-path* *default-pathname-defaults*
218 "Pathname defaults to merge into output files.")
219
8ce7eb9b
MW
220(defvar *preferred-subnets* nil
221 "Subnets to prefer when selecting defaults.")
222
fe5fb85a
MW
223;;;--------------------------------------------------------------------------
224;;; Zone infrastructure.
225
ab87c7bf
MW
226(defun zone-file-name (zone type)
227 "Choose a file name for a given ZONE and TYPE."
228 (merge-pathnames (make-pathname :name (string-downcase zone)
229 :type (string-downcase type))
230 *zone-output-path*))
231
8ce7eb9b
MW
232(defun zone-preferred-subnet-p (name)
233 "Answer whether NAME (a string or symbol) names a preferred subnet."
234 (member name *preferred-subnets* :test #'string-equal))
235
8bd2576e
MW
236(defmacro preferred-subnet-case (&body clauses)
237 "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose
238 SUBNETS (a list or single symbol, not evaluated) are considered preferred
239 by zone-preferred-subnet-p. If SUBNETS is the symbol t then the clause
240 always matches."
241 `(cond
242 ,@(mapcar (lambda (clause)
243 (let ((subnets (car clause)))
244 (cons (cond ((eq subnets t)
245 t)
246 ((listp subnets)
247 `(or ,@(mapcar (lambda (subnet)
248 `(zone-preferred-subnet-p
249 ',subnet))
250 subnets)))
251 (t
252 `(zone-preferred-subnet-p ',subnets)))
253 (cdr clause))))
254 clauses)))
255
7e282fb5 256(defun zone-process-records (rec ttl func)
257 "Sort out the list of records in REC, calling FUNC for each one. TTL is
2f1d381d 258 the default time-to-live for records which don't specify one."
7e282fb5 259 (labels ((sift (rec ttl)
260 (collecting (top sub)
261 (loop
262 (unless rec
263 (return))
264 (let ((r (pop rec)))
265 (cond ((eq r :ttl)
266 (setf ttl (pop rec)))
267 ((symbolp r)
268 (collect (make-zone-record :type r
269 :ttl ttl
270 :data (pop rec))
271 top))
272 ((listp r)
273 (dolist (name (listify (car r)))
274 (collect (make-zone-subdomain :name name
275 :ttl ttl
276 :records (cdr r))
277 sub)))
278 (t
279 (error "Unexpected record form ~A" (car r))))))))
4e7e3780 280 (process (rec dom ttl)
7e282fb5 281 (multiple-value-bind (top sub) (sift rec ttl)
282 (if (and dom (null top) sub)
8ce7eb9b
MW
283 (let ((preferred nil))
284 (dolist (s sub)
285 (when (some #'zone-preferred-subnet-p
286 (listify (zs-name s)))
287 (setf preferred s)))
288 (unless preferred
289 (setf preferred (car sub)))
290 (when preferred
291 (process (zs-records preferred)
292 dom
293 (zs-ttl preferred))))
294 (let ((name (and dom
295 (string-downcase
296 (join-strings #\. (reverse dom))))))
297 (dolist (zr top)
298 (setf (zr-name zr) name)
299 (funcall func zr))))
7e282fb5 300 (dolist (s sub)
301 (process (zs-records s)
302 (cons (zs-name s) dom)
4e7e3780
MW
303 (zs-ttl s))))))
304 (process rec nil ttl)))
7e282fb5 305
306(defun zone-parse-host (f zname)
307 "Parse a host name F: if F ends in a dot then it's considered absolute;
2f1d381d 308 otherwise it's relative to ZNAME."
7e282fb5 309 (setf f (stringify f))
310 (cond ((string= f "@") (stringify zname))
311 ((and (plusp (length f))
312 (char= (char f (1- (length f))) #\.))
313 (string-downcase (subseq f 0 (1- (length f)))))
314 (t (string-downcase (concatenate 'string f "."
315 (stringify zname))))))
7e282fb5 316(defun default-rev-zone (base bytes)
fe5fb85a 317 "Return the default reverse-zone name for the given BASE address and number
2f1d381d 318 of fixed leading BYTES."
7e282fb5 319 (join-strings #\. (collecting ()
320 (loop for i from (- 3 bytes) downto 0
321 do (collect (ipaddr-byte base i)))
322 (collect "in-addr.arpa"))))
323
324(defun zone-name-from-net (net &optional bytes)
325 "Given a NET, and maybe the BYTES to use, convert to the appropriate
2f1d381d 326 subdomain of in-addr.arpa."
7e282fb5 327 (let ((ipn (net-get-as-ipnet net)))
328 (with-ipnet (net mask) ipn
329 (unless bytes
330 (setf bytes (- 4 (ipnet-changeable-bytes mask))))
331 (join-strings #\.
332 (append (loop
333 for i from (- 4 bytes) below 4
334 collect (logand #xff (ash net (* -8 i))))
335 (list "in-addr.arpa"))))))
fe5fb85a 336
7e282fb5 337(defun zone-net-from-name (name)
338 "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
339 (let* ((name (string-downcase (stringify name)))
340 (len (length name))
341 (suffix ".in-addr.arpa")
342 (sufflen (length suffix))
343 (addr 0)
344 (n 0)
345 (end (- len sufflen)))
346 (unless (and (> len sufflen)
347 (string= name suffix :start1 end))
348 (error "`~A' not in ~A." name suffix))
349 (loop
350 with start = 0
351 for dot = (position #\. name :start start :end end)
352 for byte = (parse-integer name
353 :start start
354 :end (or dot end))
355 do (setf addr (logior addr (ash byte (* 8 n))))
356 (incf n)
357 when (>= n 4)
358 do (error "Can't deduce network from ~A." name)
359 while dot
360 do (setf start (1+ dot)))
361 (setf addr (ash addr (* 8 (- 4 n))))
362 (make-ipnet addr (* 8 n))))
363
7e282fb5 364(defun zone-parse-net (net name)
2f1d381d
MW
365 "Given a NET, and the NAME of a domain to guess from if NET is null, return
366 the ipnet for the network."
7e282fb5 367 (if net
368 (net-get-as-ipnet net)
369 (zone-net-from-name name)))
370
371(defun zone-cidr-delg-default-name (ipn bytes)
372 "Given a delegated net IPN and the parent's number of changing BYTES,
2f1d381d 373 return the default deletate zone prefix."
7e282fb5 374 (with-ipnet (net mask) ipn
375 (join-strings #\.
376 (reverse
377 (loop
378 for i from (1- bytes) downto 0
379 until (zerop (logand mask (ash #xff (* 8 i))))
380 collect (logand #xff (ash net (* -8 i))))))))
381
fe5fb85a 382;;;--------------------------------------------------------------------------
ab87c7bf
MW
383;;; Serial numbering.
384
385(defun make-zone-serial (name)
386 "Given a zone NAME, come up with a new serial number. This will (very
387 carefully) update a file ZONE.serial in the current directory."
388 (let* ((file (zone-file-name name :serial))
389 (last (with-open-file (in file
390 :direction :input
391 :if-does-not-exist nil)
392 (if in (read in)
393 (list 0 0 0 0))))
394 (now (multiple-value-bind
395 (sec min hr dy mon yr dow dstp tz)
396 (get-decoded-time)
397 (declare (ignore sec min hr dow dstp tz))
398 (list dy mon yr)))
399 (seq (cond ((not (equal now (cdr last))) 0)
400 ((< (car last) 99) (1+ (car last)))
401 (t (error "Run out of sequence numbers for ~A" name)))))
402 (safely-writing (out file)
403 (format out
404 ";; Serial number file for zone ~A~%~
405 ;; (LAST-SEQ DAY MONTH YEAR)~%~
406 ~S~%"
407 name
408 (cons seq now)))
409 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
410
411;;;--------------------------------------------------------------------------
fe5fb85a 412;;; Zone form parsing.
7e282fb5 413
414(defun zone-parse-head (head)
415 "Parse the HEAD of a zone form. This has the form
416
417 (NAME &key :source :admin :refresh :retry
418 :expire :min-ttl :ttl :serial)
419
2f1d381d
MW
420 though a singleton NAME needn't be a list. Returns the default TTL and an
421 soa structure representing the zone head."
7e282fb5 422 (destructuring-bind
423 (zname
424 &key
8a4f9a18 425 (source *default-zone-source*)
7e282fb5 426 (admin (or *default-zone-admin*
427 (format nil "hostmaster@~A" zname)))
428 (refresh *default-zone-refresh*)
429 (retry *default-zone-retry*)
430 (expire *default-zone-expire*)
431 (min-ttl *default-zone-min-ttl*)
432 (ttl min-ttl)
433 (serial (make-zone-serial zname)))
434 (listify head)
435 (values zname
436 (timespec-seconds ttl)
437 (make-soa :admin admin
438 :source (zone-parse-host source zname)
439 :refresh (timespec-seconds refresh)
440 :retry (timespec-seconds retry)
441 :expire (timespec-seconds expire)
442 :min-ttl (timespec-seconds min-ttl)
443 :serial serial))))
444
5bf80328
MW
445(defun zone-make-name (prefix zone-name)
446 (if (or (not prefix) (string= prefix "@"))
447 zone-name
448 (let ((len (length prefix)))
449 (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
450 (join-strings #\. (list prefix zone-name))
451 prefix))))
452
7e282fb5 453(defmacro defzoneparse (types (name data list
5bf80328
MW
454 &key (prefix (gensym "PREFIX"))
455 (zname (gensym "ZNAME"))
4e7e3780 456 (ttl (gensym "TTL")))
7e282fb5 457 &body body)
fe5fb85a 458 "Define a new zone record type (or TYPES -- a list of synonyms is
2f1d381d 459 permitted). The arguments are as follows:
fe5fb85a 460
2f1d381d 461 NAME The name of the record to be added.
fe5fb85a 462
2f1d381d 463 DATA The content of the record to be added (a single object,
7fff3797 464 unevaluated).
fe5fb85a 465
2f1d381d 466 LIST A function to add a record to the zone. See below.
fe5fb85a 467
5bf80328
MW
468 PREFIX The prefix tag used in the original form.
469
2f1d381d 470 ZNAME The name of the zone being constructed.
fe5fb85a 471
2f1d381d 472 TTL The TTL for this record.
fe5fb85a 473
5bf80328
MW
474 You get to choose your own names for these. ZNAME, PREFIX and TTL are
475 optional: you don't have to accept them if you're not interested.
fe5fb85a 476
2f1d381d
MW
477 The LIST argument names a function to be bound in the body to add a new
478 low-level record to the zone. It has the prototype
fe5fb85a 479
590ad961 480 (LIST &key :name :type :data :ttl :make-ptr-p)
fe5fb85a 481
590ad961
MW
482 These (except MAKE-PTR-P, which defaults to nil) default to the above
483 arguments (even if you didn't accept the arguments)."
7e282fb5 484 (setf types (listify types))
485 (let* ((type (car types))
486 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
2ec279f5 487 (with-parsed-body (body decls doc) body
590ad961 488 (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
40ded1b8
MW
489 `(progn
490 (dolist (,i ',types)
491 (setf (get ,i 'zone-parse) ',func))
5bf80328 492 (defun ,func (,prefix ,zname ,data ,ttl ,col)
40ded1b8
MW
493 ,@doc
494 ,@decls
5bf80328
MW
495 (let ((,name (zone-make-name ,prefix ,zname)))
496 (flet ((,list (&key ((:name ,tname) ,name)
497 ((:type ,ttype) ,type)
498 ((:data ,tdata) ,data)
590ad961
MW
499 ((:ttl ,tttl) ,ttl)
500 ((:make-ptr-p ,tmakeptrp) nil))
f4decf40 501 #+cmu (declare (optimize ext:inhibit-warnings))
5bf80328
MW
502 (collect (make-zone-record :name ,tname
503 :type ,ttype
504 :data ,tdata
590ad961
MW
505 :ttl ,tttl
506 :make-ptr-p ,tmakeptrp)
5bf80328
MW
507 ,col)))
508 ,@body)))
509 ',type)))))
7e282fb5 510
511(defun zone-parse-records (zone records)
512 (let ((zname (zone-name zone)))
513 (with-collection (rec)
514 (flet ((parse-record (zr)
515 (let ((func (or (get (zr-type zr) 'zone-parse)
516 (error "No parser for record ~A."
517 (zr-type zr))))
5bf80328 518 (name (and (zr-name zr) (stringify (zr-name zr)))))
7e282fb5 519 (funcall func
520 name
5bf80328 521 zname
7e282fb5 522 (zr-data zr)
523 (zr-ttl zr)
5bf80328 524 rec))))
7e282fb5 525 (zone-process-records records
526 (zone-default-ttl zone)
7fff3797 527 #'parse-record))
7e282fb5 528 (setf (zone-records zone) (nconc (zone-records zone) rec)))))
529
530(defun zone-parse (zf)
531 "Parse a ZONE form. The syntax of a zone form is as follows:
532
2f1d381d
MW
533 ZONE-FORM:
534 ZONE-HEAD ZONE-RECORD*
7e282fb5 535
2f1d381d
MW
536 ZONE-RECORD:
537 ((NAME*) ZONE-RECORD*)
538 | SYM ARGS"
7e282fb5 539 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
540 (let ((zone (make-zone :name zname
541 :default-ttl ttl
542 :soa soa
543 :records nil)))
544 (zone-parse-records zone (cdr zf))
545 zone)))
546
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
555(defmacro defzone (soa &rest zf)
556 "Zone definition macro."
557 `(zone-create '(,soa ,@zf)))
558
559(defmacro defrevzone (head &rest zf)
560 "Define a reverse zone, with the correct name."
561 (destructuring-bind
562 (net &rest soa-args)
563 (listify head)
564 (let ((bytes nil))
565 (when (and soa-args (integerp (car soa-args)))
566 (setf bytes (pop soa-args)))
567 `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
568
569;;;--------------------------------------------------------------------------
570;;; Zone record parsers.
571
4e7e3780 572(defzoneparse :a (name data rec)
7e282fb5 573 ":a IPADDR"
590ad961
MW
574 (rec :data (parse-ipaddr data) :make-ptr-p t))
575
576(defzoneparse :svc (name data rec)
577 ":svc IPADDR"
578 (rec :type :a :data (parse-ipaddr data)))
fe5fb85a 579
7e282fb5 580(defzoneparse :ptr (name data rec :zname zname)
581 ":ptr HOST"
582 (rec :data (zone-parse-host data zname)))
fe5fb85a 583
7e282fb5 584(defzoneparse :cname (name data rec :zname zname)
585 ":cname HOST"
586 (rec :data (zone-parse-host data zname)))
fe5fb85a 587
7e282fb5 588(defzoneparse :mx (name data rec :zname zname)
589 ":mx ((HOST :prio INT :ip IPADDR)*)"
590 (dolist (mx (listify data))
591 (destructuring-bind
592 (mxname &key (prio *default-mx-priority*) ip)
593 (listify mx)
594 (let ((host (zone-parse-host mxname zname)))
595 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
596 (rec :data (cons host prio))))))
fe5fb85a 597
7e282fb5 598(defzoneparse :ns (name data rec :zname zname)
599 ":ns ((HOST :ip IPADDR)*)"
600 (dolist (ns (listify data))
601 (destructuring-bind
602 (nsname &key ip)
603 (listify ns)
604 (let ((host (zone-parse-host nsname zname)))
605 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
606 (rec :data host)))))
fe5fb85a 607
7e282fb5 608(defzoneparse :alias (name data rec :zname zname)
609 ":alias (LABEL*)"
610 (dolist (a (listify data))
611 (rec :name (zone-parse-host a zname)
612 :type :cname
613 :data name)))
fe5fb85a 614
a15288b4 615(defzoneparse :net (name data rec)
616 ":net (NETWORK*)"
617 (dolist (net (listify data))
618 (let ((n (net-get-as-ipnet net)))
619 (rec :name (zone-parse-host "net" name)
620 :type :a
621 :data (ipnet-net n))
622 (rec :name (zone-parse-host "mask" name)
623 :type :a
624 :data (ipnet-mask n))
625 (rec :name (zone-parse-host "broadcast" name)
626 :type :a
627 :data (ipnet-broadcast n)))))
7fff3797 628
7e282fb5 629(defzoneparse (:rev :reverse) (name data rec)
630 ":reverse ((NET :bytes BYTES) ZONE*)"
631 (setf data (listify data))
632 (destructuring-bind
633 (net &key bytes)
634 (listify (car data))
635 (setf net (zone-parse-net net name))
636 (unless bytes
637 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
4e7e3780
MW
638 (let ((seen (make-hash-table :test #'equal)))
639 (dolist (z (or (cdr data)
640 (hash-table-keys *zones*)))
641 (dolist (zr (zone-records (zone-find z)))
642 (when (and (eq (zr-type zr) :a)
590ad961 643 (zr-make-ptr-p zr)
4e7e3780
MW
644 (ipaddr-networkp (zr-data zr) net))
645 (let ((name (string-downcase
646 (join-strings
647 #\.
648 (collecting ()
649 (dotimes (i bytes)
650 (collect (logand #xff (ash (zr-data zr)
651 (* -8 i)))))
652 (collect name))))))
653 (unless (gethash name seen)
654 (rec :name name :type :ptr
655 :ttl (zr-ttl zr) :data (zr-name zr))
656 (setf (gethash name seen) t)))))))))
7e282fb5 657
658(defzoneparse (:cidr-delegation :cidr) (name data rec)
659 ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
660 (destructuring-bind
661 (net &key bytes)
662 (listify (car data))
663 (setf net (zone-parse-net net name))
664 (unless bytes
665 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
666 (dolist (map (cdr data))
667 (destructuring-bind
668 (tnet &optional tdom)
669 (listify map)
670 (setf tnet (zone-parse-net tnet name))
671 (unless (ipnet-subnetp net tnet)
672 (error "~A is not a subnet of ~A."
673 (ipnet-pretty tnet)
7fff3797 674 (ipnet-pretty net)))
7e282fb5 675 (unless tdom
676 (with-ipnet (net mask) tnet
677 (setf tdom
678 (join-strings
679 #\.
680 (append (reverse (loop
681 for i from (1- bytes) downto 0
682 until (zerop (logand mask
683 (ash #xff
684 (* 8 i))))
685 collect (logand #xff
686 (ash net (* -8 i)))))
687 (list name))))))
688 (setf tdom (string-downcase tdom))
689 (dotimes (i (ipnet-hosts tnet))
690 (let* ((addr (ipnet-host tnet i))
691 (tail (join-strings #\.
692 (loop
693 for i from 0 below bytes
694 collect
695 (logand #xff
696 (ash addr (* 8 i)))))))
697 (rec :name (format nil "~A.~A" tail name)
698 :type :cname
699 :data (format nil "~A.~A" tail tdom))))))))
700
fe5fb85a
MW
701;;;--------------------------------------------------------------------------
702;;; Zone file output.
7e282fb5 703
a567a3bc
MW
704(defgeneric zone-write (format zone stream)
705 (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
706
707(defvar *writing-zone* nil
708 "The zone currently being written.")
709
710(defvar *zone-output-stream* nil
711 "Stream to write zone data on.")
712
713(defmethod zone-write :around (format zone stream)
714 (let ((*writing-zone* zone)
715 (*zone-output-stream* stream))
716 (call-next-method)))
717
718(defun zone-save (zones &key (format :bind))
719 "Write the named ZONES to files. If no zones are given, write all the
720 zones."
721 (unless zones
722 (setf zones (hash-table-keys *zones*)))
723 (safely (safe)
724 (dolist (z zones)
725 (let ((zz (zone-find z)))
726 (unless zz
727 (error "Unknown zone `~A'." z))
728 (let ((stream (safely-open-output-stream safe
729 (zone-file-name z :zone))))
730 (zone-write format zz stream))))))
731
732;;;--------------------------------------------------------------------------
733;;; Bind format output.
734
735(defun bind-hostname (hostname)
736 (if (not hostname)
737 "@"
738 (let* ((h (string-downcase (stringify hostname)))
739 (hl (length h))
740 (r (string-downcase (zone-name *writing-zone*)))
741 (rl (length r)))
742 (cond ((string= r h) "@")
743 ((and (> hl rl)
744 (char= (char h (- hl rl 1)) #\.)
745 (string= h r :start1 (- hl rl)))
746 (subseq h 0 (- hl rl 1)))
747 (t (concatenate 'string h "."))))))
748
749(defmethod zone-write ((format (eql :bind)) zone stream)
750 (format stream "~
7e282fb5 751;;; Zone file `~(~A~)'
752;;; (generated ~A)
753
7d593efd
MW
754$ORIGIN ~0@*~(~A.~)
755$TTL ~2@*~D~2%"
7e282fb5 756 (zone-name zone)
757 (iso-date :now :datep t :timep t)
758 (zone-default-ttl zone))
a567a3bc
MW
759 (let* ((soa (zone-soa zone))
760 (admin (let* ((name (soa-admin soa))
761 (at (position #\@ name))
762 (copy (format nil "~(~A~)." name)))
763 (when at
764 (setf (char copy at) #\.))
765 copy)))
7e282fb5 766 (format stream "~
767~A~30TIN SOA~40T~A ~A (
768~45T~10D~60T ;serial
769~45T~10D~60T ;refresh
770~45T~10D~60T ;retry
771~45T~10D~60T ;expire
772~45T~10D )~60T ;min-ttl~2%"
a567a3bc
MW
773 (bind-hostname (zone-name zone))
774 (bind-hostname (soa-source soa))
775 admin
7e282fb5 776 (soa-serial soa)
777 (soa-refresh soa)
778 (soa-retry soa)
779 (soa-expire soa)
780 (soa-min-ttl soa)))
a567a3bc
MW
781 (dolist (zr (zone-records zone))
782 (bind-record (zr-type zr) zr)))
783
784(defgeneric bind-record (type zr))
785
786(defun bind-format-record (name ttl type format args)
787 (format *zone-output-stream*
788 "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
789 (bind-hostname name)
790 (and (/= ttl (zone-default-ttl *writing-zone*))
791 ttl)
792 (string-upcase (symbol-name type))
793 format args))
794
795(defmethod bind-record (type zr)
796 (destructuring-bind (format &rest args)
797 (bind-record-format-args type (zr-data zr))
798 (bind-format-record (zr-name zr)
799 (zr-ttl zr)
800 (bind-record-type type)
801 format args)))
802
803(defgeneric bind-record-type (type)
804 (:method (type) type))
805
806(defgeneric bind-record-format-args (type data)
807 (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
808 (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
809 (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
810 (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
811 (:method ((type (eql :mx)) data)
812 (list "~2D ~A" (cdr data) (bind-hostname (car data))))
813 (:method ((type (eql :txt)) data) (list "~S" (stringify data))))
7e282fb5 814
815;;;----- That's all, folks --------------------------------------------------