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