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