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