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