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