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