chiark / gitweb /
zone: Simplify zone-write.
[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*
5fbfaf49
MW
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
2f1d381d 52 representation. Convert VAL, a list of digits, into an integer."
fe5fb85a
MW
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
2f1d381d 60 representation. Convert VAL, an integer, into a list of digits."
fe5fb85a
MW
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
2f1d381d
MW
73 seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious
74 time units."
fe5fb85a
MW
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
2f1d381d
MW
102 time to convert, which defaults to now; DATEP is whether to emit the date;
103 TIMEP is whether to emit the time, and SEP (default is space) is how to
104 separate the two."
fe5fb85a
MW
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
51a6847e
MW
147#+ecl
148(cffi:defcfun gethostname :int
149 (name :pointer)
150 (len :uint))
151
7e282fb5 152(defvar *default-zone-source*
7d593efd 153 (let ((hn #+cmu (unix:unix-gethostname)
51a6847e
MW
154 #+clisp (unix:get-host-name)
155 #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
156 (let ((rc (gethostname buffer len)))
157 (unless (zerop rc)
158 (error "gethostname(2) failed (rc = ~A)." rc))))))
8a4f9a18 159 (and hn (concatenate 'string (canonify-hostname hn) ".")))
7e282fb5 160 "The default zone source: the current host's name.")
fe5fb85a 161
7e282fb5 162(defvar *default-zone-refresh* (* 24 60 60)
163 "Default zone refresh interval: one day.")
fe5fb85a 164
7e282fb5 165(defvar *default-zone-admin* nil
166 "Default zone administrator's email address.")
fe5fb85a 167
7e282fb5 168(defvar *default-zone-retry* (* 60 60)
169 "Default znoe retry interval: one hour.")
fe5fb85a 170
7e282fb5 171(defvar *default-zone-expire* (* 14 24 60 60)
172 "Default zone expiry time: two weeks.")
fe5fb85a 173
7e282fb5 174(defvar *default-zone-min-ttl* (* 4 60 60)
175 "Default zone minimum TTL/negative TTL: four hours.")
fe5fb85a 176
7e282fb5 177(defvar *default-zone-ttl* (* 8 60 60)
178 "Default zone TTL (for records without explicit TTLs): 8 hours.")
fe5fb85a 179
7e282fb5 180(defvar *default-mx-priority* 50
181 "Default MX priority.")
182
fe5fb85a
MW
183;;;--------------------------------------------------------------------------
184;;; Serial numbering.
7e282fb5 185
186(defun make-zone-serial (name)
187 "Given a zone NAME, come up with a new serial number. This will (very
2f1d381d 188 carefully) update a file ZONE.serial in the current directory."
7e282fb5 189 (let* ((file (format nil "~(~A~).serial" name))
190 (last (with-open-file (in file
191 :direction :input
192 :if-does-not-exist nil)
193 (if in (read in)
194 (list 0 0 0 0))))
195 (now (multiple-value-bind
196 (sec min hr dy mon yr dow dstp tz)
197 (get-decoded-time)
198 (declare (ignore sec min hr dow dstp tz))
199 (list dy mon yr)))
200 (seq (cond ((not (equal now (cdr last))) 0)
201 ((< (car last) 99) (1+ (car last)))
202 (t (error "Run out of sequence numbers for ~A" name)))))
203 (safely-writing (out file)
204 (format out
205 ";; Serial number file for zone ~A~%~
206 ;; (LAST-SEQ DAY MONTH YEAR)~%~
207 ~S~%"
208 name
209 (cons seq now)))
210 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
211
fe5fb85a
MW
212;;;--------------------------------------------------------------------------
213;;; Zone variables and structures.
214
7e282fb5 215(defvar *zones* (make-hash-table :test #'equal)
216 "Map of known zones.")
fe5fb85a 217
7e282fb5 218(defun zone-find (name)
219 "Find a zone given its NAME."
220 (gethash (string-downcase (stringify name)) *zones*))
fe5fb85a 221
7e282fb5 222(defun (setf zone-find) (zone name)
223 "Make the zone NAME map to ZONE."
224 (setf (gethash (string-downcase (stringify name)) *zones*) zone))
225
226(defstruct (zone-record (:conc-name zr-))
227 "A zone record."
228 (name '<unnamed>)
229 ttl
230 type
231 (defsubp nil)
232 data)
233
234(defstruct (zone-subdomain (:conc-name zs-))
235 "A subdomain. Slightly weird. Used internally by zone-process-records
2f1d381d 236 below, and shouldn't escape."
7e282fb5 237 name
238 ttl
239 records)
240
fe5fb85a
MW
241;;;--------------------------------------------------------------------------
242;;; Zone infrastructure.
243
7e282fb5 244(defun zone-process-records (rec ttl func)
245 "Sort out the list of records in REC, calling FUNC for each one. TTL is
2f1d381d 246 the default time-to-live for records which don't specify one."
7e282fb5 247 (labels ((sift (rec ttl)
248 (collecting (top sub)
249 (loop
250 (unless rec
251 (return))
252 (let ((r (pop rec)))
253 (cond ((eq r :ttl)
254 (setf ttl (pop rec)))
255 ((symbolp r)
256 (collect (make-zone-record :type r
257 :ttl ttl
258 :data (pop rec))
259 top))
260 ((listp r)
261 (dolist (name (listify (car r)))
262 (collect (make-zone-subdomain :name name
263 :ttl ttl
264 :records (cdr r))
265 sub)))
266 (t
267 (error "Unexpected record form ~A" (car r))))))))
268 (process (rec dom ttl defsubp)
269 (multiple-value-bind (top sub) (sift rec ttl)
270 (if (and dom (null top) sub)
271 (let ((s (pop sub)))
272 (process (zs-records s)
273 dom
274 (zs-ttl s)
275 defsubp)
276 (process (zs-records s)
277 (cons (zs-name s) dom)
278 (zs-ttl s)
279 t))
280 (let ((name (and dom
281 (string-downcase
282 (join-strings #\. (reverse dom))))))
283 (dolist (zr top)
284 (setf (zr-name zr) name)
285 (setf (zr-defsubp zr) defsubp)
286 (funcall func zr))))
287 (dolist (s sub)
288 (process (zs-records s)
289 (cons (zs-name s) dom)
290 (zs-ttl s)
291 defsubp)))))
292 (process rec nil ttl nil)))
293
294(defun zone-parse-host (f zname)
295 "Parse a host name F: if F ends in a dot then it's considered absolute;
2f1d381d 296 otherwise it's relative to ZNAME."
7e282fb5 297 (setf f (stringify f))
298 (cond ((string= f "@") (stringify zname))
299 ((and (plusp (length f))
300 (char= (char f (1- (length f))) #\.))
301 (string-downcase (subseq f 0 (1- (length f)))))
302 (t (string-downcase (concatenate 'string f "."
303 (stringify zname))))))
7e282fb5 304(defun default-rev-zone (base bytes)
fe5fb85a 305 "Return the default reverse-zone name for the given BASE address and number
2f1d381d 306 of fixed leading BYTES."
7e282fb5 307 (join-strings #\. (collecting ()
308 (loop for i from (- 3 bytes) downto 0
309 do (collect (ipaddr-byte base i)))
310 (collect "in-addr.arpa"))))
311
312(defun zone-name-from-net (net &optional bytes)
313 "Given a NET, and maybe the BYTES to use, convert to the appropriate
2f1d381d 314 subdomain of in-addr.arpa."
7e282fb5 315 (let ((ipn (net-get-as-ipnet net)))
316 (with-ipnet (net mask) ipn
317 (unless bytes
318 (setf bytes (- 4 (ipnet-changeable-bytes mask))))
319 (join-strings #\.
320 (append (loop
321 for i from (- 4 bytes) below 4
322 collect (logand #xff (ash net (* -8 i))))
323 (list "in-addr.arpa"))))))
fe5fb85a 324
7e282fb5 325(defun zone-net-from-name (name)
326 "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
327 (let* ((name (string-downcase (stringify name)))
328 (len (length name))
329 (suffix ".in-addr.arpa")
330 (sufflen (length suffix))
331 (addr 0)
332 (n 0)
333 (end (- len sufflen)))
334 (unless (and (> len sufflen)
335 (string= name suffix :start1 end))
336 (error "`~A' not in ~A." name suffix))
337 (loop
338 with start = 0
339 for dot = (position #\. name :start start :end end)
340 for byte = (parse-integer name
341 :start start
342 :end (or dot end))
343 do (setf addr (logior addr (ash byte (* 8 n))))
344 (incf n)
345 when (>= n 4)
346 do (error "Can't deduce network from ~A." name)
347 while dot
348 do (setf start (1+ dot)))
349 (setf addr (ash addr (* 8 (- 4 n))))
350 (make-ipnet addr (* 8 n))))
351
7e282fb5 352(defun zone-parse-net (net name)
2f1d381d
MW
353 "Given a NET, and the NAME of a domain to guess from if NET is null, return
354 the ipnet for the network."
7e282fb5 355 (if net
356 (net-get-as-ipnet net)
357 (zone-net-from-name name)))
358
359(defun zone-cidr-delg-default-name (ipn bytes)
360 "Given a delegated net IPN and the parent's number of changing BYTES,
2f1d381d 361 return the default deletate zone prefix."
7e282fb5 362 (with-ipnet (net mask) ipn
363 (join-strings #\.
364 (reverse
365 (loop
366 for i from (1- bytes) downto 0
367 until (zerop (logand mask (ash #xff (* 8 i))))
368 collect (logand #xff (ash net (* -8 i))))))))
369
370(defun zone-cidr-delegation (data name ttl list)
371 "Given :cidr-delegation info DATA, for a record called NAME and the current
2f1d381d 372 TTL, write lots of CNAME records to LIST."
7e282fb5 373 (destructuring-bind
374 (net &key bytes)
375 (listify (car data))
376 (setf net (zone-parse-net net name))
377 (unless bytes
378 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
379 (dolist (map (cdr data))
380 (destructuring-bind
381 (tnet &optional tdom)
382 (listify map)
383 (setf tnet (zone-parse-net tnet name))
384 (unless (ipnet-subnetp net tnet)
385 (error "~A is not a subnet of ~A."
386 (ipnet-pretty tnet)
7fff3797 387 (ipnet-pretty net)))
7e282fb5 388 (unless tdom
389 (setf tdom
390 (join-strings #\.
391 (list (zone-cidr-delg-default-name tnet bytes)
392 name))))
393 (setf tdom (string-downcase tdom))
394 (dotimes (i (ipnet-hosts tnet))
395 (let* ((addr (ipnet-host tnet i))
396 (tail (join-strings #\.
397 (loop
398 for i from 0 below bytes
399 collect
400 (logand #xff
401 (ash addr (* 8 i)))))))
402 (collect (make-zone-record
403 :name (join-strings #\.
404 (list tail name))
405 :type :cname
406 :ttl ttl
407 :data (join-strings #\. (list tail tdom)))
408 list)))))))
7fff3797 409
fe5fb85a
MW
410;;;--------------------------------------------------------------------------
411;;; Zone form parsing.
7e282fb5 412
413(defun zone-parse-head (head)
414 "Parse the HEAD of a zone form. This has the form
415
416 (NAME &key :source :admin :refresh :retry
417 :expire :min-ttl :ttl :serial)
418
2f1d381d
MW
419 though a singleton NAME needn't be a list. Returns the default TTL and an
420 soa structure representing the zone head."
7e282fb5 421 (destructuring-bind
422 (zname
423 &key
8a4f9a18 424 (source *default-zone-source*)
7e282fb5 425 (admin (or *default-zone-admin*
426 (format nil "hostmaster@~A" zname)))
427 (refresh *default-zone-refresh*)
428 (retry *default-zone-retry*)
429 (expire *default-zone-expire*)
430 (min-ttl *default-zone-min-ttl*)
431 (ttl min-ttl)
432 (serial (make-zone-serial zname)))
433 (listify head)
434 (values zname
435 (timespec-seconds ttl)
436 (make-soa :admin admin
437 :source (zone-parse-host source zname)
438 :refresh (timespec-seconds refresh)
439 :retry (timespec-seconds retry)
440 :expire (timespec-seconds expire)
441 :min-ttl (timespec-seconds min-ttl)
442 :serial serial))))
443
7e282fb5 444(defmacro defzoneparse (types (name data list
445 &key (zname (gensym "ZNAME"))
446 (ttl (gensym "TTL"))
447 (defsubp (gensym "DEFSUBP")))
448 &body body)
fe5fb85a 449 "Define a new zone record type (or TYPES -- a list of synonyms is
2f1d381d 450 permitted). The arguments are as follows:
fe5fb85a 451
2f1d381d 452 NAME The name of the record to be added.
fe5fb85a 453
2f1d381d 454 DATA The content of the record to be added (a single object,
7fff3797 455 unevaluated).
fe5fb85a 456
2f1d381d 457 LIST A function to add a record to the zone. See below.
fe5fb85a 458
2f1d381d 459 ZNAME The name of the zone being constructed.
fe5fb85a 460
2f1d381d 461 TTL The TTL for this record.
fe5fb85a 462
2f1d381d 463 DEFSUBP Whether this is the default subdomain for this entry.
fe5fb85a 464
2f1d381d
MW
465 You get to choose your own names for these. ZNAME, TTL and DEFSUBP are
466 optional: you don't have to accept them if you're not interested.
fe5fb85a 467
2f1d381d
MW
468 The LIST argument names a function to be bound in the body to add a new
469 low-level record to the zone. It has the prototype
fe5fb85a 470
2f1d381d 471 (LIST &key :name :type :data :ttl :defsubp)
fe5fb85a 472
2f1d381d
MW
473 Except for defsubp, these default to the above arguments (even if you
474 didn't accept the arguments)."
7e282fb5 475 (setf types (listify types))
476 (let* ((type (car types))
477 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
2ec279f5 478 (with-parsed-body (body decls doc) body
40ded1b8
MW
479 (with-gensyms (col tname ttype tttl tdata tdefsubp i)
480 `(progn
481 (dolist (,i ',types)
482 (setf (get ,i 'zone-parse) ',func))
483 (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
484 ,@doc
485 ,@decls
486 (declare (ignorable ,zname ,defsubp))
487 (flet ((,list (&key ((:name ,tname) ,name)
488 ((:type ,ttype) ,type)
489 ((:data ,tdata) ,data)
490 ((:ttl ,tttl) ,ttl)
491 ((:defsubp ,tdefsubp) nil))
492 (collect (make-zone-record :name ,tname
493 :type ,ttype
494 :data ,tdata
495 :ttl ,tttl
496 :defsubp ,tdefsubp)
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))))
508 (name (and (zr-name zr)
509 (stringify (zr-name zr)))))
510 (if (or (not name)
511 (string= name "@"))
512 (setf name zname)
513 (let ((len (length name)))
514 (if (or (zerop len)
515 (char/= (char name (1- len)) #\.))
516 (setf name (join-strings #\.
517 (list name zname))))))
518 (funcall func
519 name
520 (zr-data zr)
521 (zr-ttl zr)
522 rec
523 zname
524 (zr-defsubp zr)))))
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
7e282fb5 572(defzoneparse :a (name data rec :defsubp defsubp)
573 ":a IPADDR"
574 (rec :data (parse-ipaddr data) :defsubp defsubp))
fe5fb85a 575
7e282fb5 576(defzoneparse :ptr (name data rec :zname zname)
577 ":ptr HOST"
578 (rec :data (zone-parse-host data zname)))
fe5fb85a 579
7e282fb5 580(defzoneparse :cname (name data rec :zname zname)
581 ":cname HOST"
582 (rec :data (zone-parse-host data zname)))
fe5fb85a 583
7e282fb5 584(defzoneparse :mx (name data rec :zname zname)
585 ":mx ((HOST :prio INT :ip IPADDR)*)"
586 (dolist (mx (listify data))
587 (destructuring-bind
588 (mxname &key (prio *default-mx-priority*) ip)
589 (listify mx)
590 (let ((host (zone-parse-host mxname zname)))
591 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
592 (rec :data (cons host prio))))))
fe5fb85a 593
7e282fb5 594(defzoneparse :ns (name data rec :zname zname)
595 ":ns ((HOST :ip IPADDR)*)"
596 (dolist (ns (listify data))
597 (destructuring-bind
598 (nsname &key ip)
599 (listify ns)
600 (let ((host (zone-parse-host nsname zname)))
601 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
602 (rec :data host)))))
fe5fb85a 603
7e282fb5 604(defzoneparse :alias (name data rec :zname zname)
605 ":alias (LABEL*)"
606 (dolist (a (listify data))
607 (rec :name (zone-parse-host a zname)
608 :type :cname
609 :data name)))
fe5fb85a 610
a15288b4 611(defzoneparse :net (name data rec)
612 ":net (NETWORK*)"
613 (dolist (net (listify data))
614 (let ((n (net-get-as-ipnet net)))
615 (rec :name (zone-parse-host "net" name)
616 :type :a
617 :data (ipnet-net n))
618 (rec :name (zone-parse-host "mask" name)
619 :type :a
620 :data (ipnet-mask n))
621 (rec :name (zone-parse-host "broadcast" name)
622 :type :a
623 :data (ipnet-broadcast n)))))
7fff3797 624
7e282fb5 625(defzoneparse (:rev :reverse) (name data rec)
626 ":reverse ((NET :bytes BYTES) ZONE*)"
627 (setf data (listify data))
628 (destructuring-bind
629 (net &key bytes)
630 (listify (car data))
631 (setf net (zone-parse-net net name))
632 (unless bytes
633 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
634 (dolist (z (or (cdr data)
635 (hash-table-keys *zones*)))
636 (dolist (zr (zone-records (zone-find z)))
637 (when (and (eq (zr-type zr) :a)
638 (not (zr-defsubp zr))
639 (ipaddr-networkp (zr-data zr) net))
640 (rec :name (string-downcase
641 (join-strings
642 #\.
643 (collecting ()
644 (dotimes (i bytes)
645 (collect (logand #xff (ash (zr-data zr)
646 (* -8 i)))))
647 (collect name))))
648 :type :ptr
649 :ttl (zr-ttl zr)
650 :data (zr-name zr)))))))
651
652(defzoneparse (:cidr-delegation :cidr) (name data rec)
653 ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
654 (destructuring-bind
655 (net &key bytes)
656 (listify (car data))
657 (setf net (zone-parse-net net name))
658 (unless bytes
659 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
660 (dolist (map (cdr data))
661 (destructuring-bind
662 (tnet &optional tdom)
663 (listify map)
664 (setf tnet (zone-parse-net tnet name))
665 (unless (ipnet-subnetp net tnet)
666 (error "~A is not a subnet of ~A."
667 (ipnet-pretty tnet)
7fff3797 668 (ipnet-pretty net)))
7e282fb5 669 (unless tdom
670 (with-ipnet (net mask) tnet
671 (setf tdom
672 (join-strings
673 #\.
674 (append (reverse (loop
675 for i from (1- bytes) downto 0
676 until (zerop (logand mask
677 (ash #xff
678 (* 8 i))))
679 collect (logand #xff
680 (ash net (* -8 i)))))
681 (list name))))))
682 (setf tdom (string-downcase tdom))
683 (dotimes (i (ipnet-hosts tnet))
684 (let* ((addr (ipnet-host tnet i))
685 (tail (join-strings #\.
686 (loop
687 for i from 0 below bytes
688 collect
689 (logand #xff
690 (ash addr (* 8 i)))))))
691 (rec :name (format nil "~A.~A" tail name)
692 :type :cname
693 :data (format nil "~A.~A" tail tdom))))))))
694
fe5fb85a
MW
695;;;--------------------------------------------------------------------------
696;;; Zone file output.
7e282fb5 697
698(defun zone-write (zone &optional (stream *standard-output*))
699 "Write a ZONE's records to STREAM."
700 (labels ((fix-admin (a)
701 (let ((at (position #\@ a))
702 (s (concatenate 'string (string-downcase a) ".")))
703 (when s
704 (setf (char s at) #\.))
705 s))
706 (fix-host (h)
707 (if (not h)
708 "@"
709 (let* ((h (string-downcase (stringify h)))
710 (hl (length h))
711 (r (string-downcase (zone-name zone)))
712 (rl (length r)))
713 (cond ((string= r h) "@")
714 ((and (> hl rl)
715 (char= (char h (- hl rl 1)) #\.)
716 (string= h r :start1 (- hl rl)))
717 (subseq h 0 (- hl rl 1)))
718 (t (concatenate 'string h "."))))))
719 (printrec (zr)
720 (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
721 (fix-host (zr-name zr))
722 (and (/= (zr-ttl zr) (zone-default-ttl zone))
723 (zr-ttl zr))
724 (string-upcase (symbol-name (zr-type zr))))))
725 (format stream "~
726;;; Zone file `~(~A~)'
727;;; (generated ~A)
728
7d593efd
MW
729$ORIGIN ~0@*~(~A.~)
730$TTL ~2@*~D~2%"
7e282fb5 731 (zone-name zone)
732 (iso-date :now :datep t :timep t)
733 (zone-default-ttl zone))
734 (let ((soa (zone-soa zone)))
735 (format stream "~
736~A~30TIN SOA~40T~A ~A (
737~45T~10D~60T ;serial
738~45T~10D~60T ;refresh
739~45T~10D~60T ;retry
740~45T~10D~60T ;expire
741~45T~10D )~60T ;min-ttl~2%"
742 (fix-host (zone-name zone))
743 (fix-host (soa-source soa))
744 (fix-admin (soa-admin soa))
745 (soa-serial soa)
746 (soa-refresh soa)
747 (soa-retry soa)
748 (soa-expire soa)
749 (soa-min-ttl soa)))
750 (dolist (zr (zone-records zone))
167608ee 751 (ecase (zr-type zr)
7e282fb5 752 (:a
753 (printrec zr)
754 (format stream "~A~%" (ipaddr-string (zr-data zr))))
167608ee 755 ((:ptr :cname :ns)
7e282fb5 756 (printrec zr)
757 (format stream "~A~%" (fix-host (zr-data zr))))
758 (:mx
759 (printrec zr)
760 (let ((mx (zr-data zr)))
761 (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
762 (:txt
763 (printrec zr)
764 (format stream "~S~%" (stringify (zr-data zr))))))))
765
7e282fb5 766(defun zone-save (zones)
767 "Write the named ZONES to files. If no zones are given, write all the
2f1d381d 768 zones."
7e282fb5 769 (unless zones
770 (setf zones (hash-table-keys *zones*)))
771 (safely (safe)
772 (dolist (z zones)
773 (let ((zz (zone-find z)))
774 (unless zz
775 (error "Unknown zone `~A'." z))
776 (let ((stream (safely-open-output-stream safe
1c472e03
MW
777 (format nil
778 "~(~A~).zone"
779 z))))
7e282fb5 780 (zone-write zz stream))))))
781
782;;;----- That's all, folks --------------------------------------------------