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