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