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