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