chiark / gitweb /
net.lisp, zone.lisp: Improve commentary and docstrings.
[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
f4e0c48f 66 A timespec may be a real count of seconds, or a list (COUNT UNIT). UNIT
f38bc59e 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-))
f4e0c48f
MW
203 "A subdomain.
204
205 Slightly weird. Used internally by `zone-process-records', and shouldn't
206 escape."
7e282fb5 207 name
208 ttl
209 records)
210
afa2e2f1 211(export '*zone-output-path*)
3d7852d9
MW
212(defvar *zone-output-path* nil
213 "Pathname defaults to merge into output files.
214
215 If this is nil then use the prevailing `*default-pathname-defaults*'.
216 This is not the same as capturing the `*default-pathname-defaults*' from
217 load time.")
ab87c7bf 218
afa2e2f1 219(export '*preferred-subnets*)
8ce7eb9b
MW
220(defvar *preferred-subnets* nil
221 "Subnets to prefer when selecting defaults.")
222
fe5fb85a
MW
223;;;--------------------------------------------------------------------------
224;;; Zone infrastructure.
225
ab87c7bf
MW
226(defun zone-file-name (zone type)
227 "Choose a file name for a given ZONE and TYPE."
228 (merge-pathnames (make-pathname :name (string-downcase zone)
229 :type (string-downcase type))
3d7852d9 230 (or *zone-output-path* *default-pathname-defaults*)))
ab87c7bf 231
afa2e2f1 232(export 'zone-preferred-subnet-p)
8ce7eb9b
MW
233(defun zone-preferred-subnet-p (name)
234 "Answer whether NAME (a string or symbol) names a preferred subnet."
235 (member name *preferred-subnets* :test #'string-equal))
236
afa2e2f1 237(export 'preferred-subnet-case)
8bd2576e 238(defmacro preferred-subnet-case (&body clauses)
f4e0c48f 239 "Execute a form based on which networks are considered preferred.
f38bc59e 240
f4e0c48f
MW
241 The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
242 whose SUBNETS (a list or single symbol, not evaluated) are listed in
243 `*preferred-subnets*'. If SUBNETS is the symbol `t' then the clause
244 always matches."
8bd2576e
MW
245 `(cond
246 ,@(mapcar (lambda (clause)
247 (let ((subnets (car clause)))
248 (cons (cond ((eq subnets t)
249 t)
250 ((listp subnets)
251 `(or ,@(mapcar (lambda (subnet)
252 `(zone-preferred-subnet-p
253 ',subnet))
254 subnets)))
255 (t
256 `(zone-preferred-subnet-p ',subnets)))
257 (cdr clause))))
258 clauses)))
259
7e282fb5 260(defun zone-process-records (rec ttl func)
f38bc59e
MW
261 "Sort out the list of records in REC, calling FUNC for each one.
262
baad8564
MW
263 TTL is the default time-to-live for records which don't specify one.
264
f4e0c48f
MW
265 REC is a list of records of the form
266
267 ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)
268
269 The various kinds of entries have the following meanings.
270
271 :ttl TTL Set the TTL for subsequent records (at this level of
272 nesting only).
273
274 TYPE DATA Define a record with a particular TYPE and DATA.
275 Record types are defined using `defzoneparse' and
276 the syntax of the data is idiosyncratic.
277
278 ((LABEL ...) . REC) Define records for labels within the zone. Any
279 records defined within REC will have their domains
280 prefixed by each of the LABELs. A singleton list
281 of labels may instead be written as a single
282 label. Note, therefore, that
283
284 (host (sub :a \"169.254.1.1\"))
baad8564 285
f4e0c48f 286 defines a record for `host.sub' -- not `sub.host'.
baad8564 287
f4e0c48f
MW
288 If REC contains no top-level records, but it does define records for a
289 label listed in `*preferred-subnets*', then the records for the first such
290 label are also promoted to top-level.
baad8564 291
f4e0c48f
MW
292 The FUNC is called for each record encountered, represented as a
293 `zone-record' object. Zone parsers are not called: you get the record
294 types and data from the input form; see `zone-parse-records' if you want
295 the raw output."
baad8564 296
7e282fb5 297 (labels ((sift (rec ttl)
f4e0c48f
MW
298 ;; Parse the record list REC into lists of `zone-record' and
299 ;; `zone-subdomain' objects, sorting out TTLs and so on.
300 ;; Returns them as two values.
301
7e282fb5 302 (collecting (top sub)
303 (loop
304 (unless rec
305 (return))
306 (let ((r (pop rec)))
307 (cond ((eq r :ttl)
308 (setf ttl (pop rec)))
309 ((symbolp r)
310 (collect (make-zone-record :type r
311 :ttl ttl
312 :data (pop rec))
313 top))
314 ((listp r)
315 (dolist (name (listify (car r)))
316 (collect (make-zone-subdomain :name name
317 :ttl ttl
318 :records (cdr r))
319 sub)))
320 (t
321 (error "Unexpected record form ~A" (car r))))))))
f4e0c48f 322
4e7e3780 323 (process (rec dom ttl)
f4e0c48f
MW
324 ;; Recursirvely process the record list REC, with a list DOM of
325 ;; prefix labels, and a default TTL. Promote records for a
326 ;; preferred subnet to toplevel if there are no toplevel records
327 ;; already.
328
7e282fb5 329 (multiple-value-bind (top sub) (sift rec ttl)
330 (if (and dom (null top) sub)
64e34a97
MW
331 (let ((preferred
332 (or (find-if (lambda (s)
333 (some #'zone-preferred-subnet-p
334 (listify (zs-name s))))
335 sub)
336 (car sub))))
8ce7eb9b
MW
337 (when preferred
338 (process (zs-records preferred)
339 dom
340 (zs-ttl preferred))))
341 (let ((name (and dom
342 (string-downcase
343 (join-strings #\. (reverse dom))))))
344 (dolist (zr top)
345 (setf (zr-name zr) name)
346 (funcall func zr))))
7e282fb5 347 (dolist (s sub)
348 (process (zs-records s)
349 (cons (zs-name s) dom)
4e7e3780 350 (zs-ttl s))))))
f4e0c48f
MW
351
352 ;; Process the records we're given with no prefix.
4e7e3780 353 (process rec nil ttl)))
7e282fb5 354
afa2e2f1 355(export 'zone-parse-host)
7e282fb5 356(defun zone-parse-host (f zname)
f4e0c48f
MW
357 "Parse a host name F.
358
359 If F ends in a dot then it's considered absolute; otherwise it's relative
360 to ZNAME."
7e282fb5 361 (setf f (stringify f))
362 (cond ((string= f "@") (stringify zname))
363 ((and (plusp (length f))
364 (char= (char f (1- (length f))) #\.))
365 (string-downcase (subseq f 0 (1- (length f)))))
366 (t (string-downcase (concatenate 'string f "."
367 (stringify zname))))))
7e282fb5 368(defun default-rev-zone (base bytes)
fe5fb85a 369 "Return the default reverse-zone name for the given BASE address and number
2f1d381d 370 of fixed leading BYTES."
7e282fb5 371 (join-strings #\. (collecting ()
372 (loop for i from (- 3 bytes) downto 0
373 do (collect (ipaddr-byte base i)))
374 (collect "in-addr.arpa"))))
375
376(defun zone-name-from-net (net &optional bytes)
377 "Given a NET, and maybe the BYTES to use, convert to the appropriate
2f1d381d 378 subdomain of in-addr.arpa."
7e282fb5 379 (let ((ipn (net-get-as-ipnet net)))
380 (with-ipnet (net mask) ipn
381 (unless bytes
382 (setf bytes (- 4 (ipnet-changeable-bytes mask))))
383 (join-strings #\.
384 (append (loop
385 for i from (- 4 bytes) below 4
386 collect (logand #xff (ash net (* -8 i))))
387 (list "in-addr.arpa"))))))
fe5fb85a 388
7e282fb5 389(defun zone-net-from-name (name)
390 "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
391 (let* ((name (string-downcase (stringify name)))
392 (len (length name))
393 (suffix ".in-addr.arpa")
394 (sufflen (length suffix))
395 (addr 0)
396 (n 0)
397 (end (- len sufflen)))
398 (unless (and (> len sufflen)
399 (string= name suffix :start1 end))
400 (error "`~A' not in ~A." name suffix))
401 (loop
402 with start = 0
403 for dot = (position #\. name :start start :end end)
404 for byte = (parse-integer name
405 :start start
406 :end (or dot end))
407 do (setf addr (logior addr (ash byte (* 8 n))))
408 (incf n)
409 when (>= n 4)
410 do (error "Can't deduce network from ~A." name)
411 while dot
412 do (setf start (1+ dot)))
413 (setf addr (ash addr (* 8 (- 4 n))))
414 (make-ipnet addr (* 8 n))))
415
7e282fb5 416(defun zone-parse-net (net name)
2f1d381d
MW
417 "Given a NET, and the NAME of a domain to guess from if NET is null, return
418 the ipnet for the network."
7e282fb5 419 (if net
420 (net-get-as-ipnet net)
421 (zone-net-from-name name)))
422
423(defun zone-cidr-delg-default-name (ipn bytes)
424 "Given a delegated net IPN and the parent's number of changing BYTES,
2f1d381d 425 return the default deletate zone prefix."
7e282fb5 426 (with-ipnet (net mask) ipn
427 (join-strings #\.
428 (reverse
429 (loop
430 for i from (1- bytes) downto 0
431 until (zerop (logand mask (ash #xff (* 8 i))))
432 collect (logand #xff (ash net (* -8 i))))))))
433
fe5fb85a 434;;;--------------------------------------------------------------------------
ab87c7bf
MW
435;;; Serial numbering.
436
afa2e2f1 437(export 'make-zone-serial)
ab87c7bf 438(defun make-zone-serial (name)
f38bc59e
MW
439 "Given a zone NAME, come up with a new serial number.
440
441 This will (very carefully) update a file ZONE.serial in the current
442 directory."
ab87c7bf
MW
443 (let* ((file (zone-file-name name :serial))
444 (last (with-open-file (in file
445 :direction :input
446 :if-does-not-exist nil)
447 (if in (read in)
448 (list 0 0 0 0))))
449 (now (multiple-value-bind
450 (sec min hr dy mon yr dow dstp tz)
451 (get-decoded-time)
452 (declare (ignore sec min hr dow dstp tz))
453 (list dy mon yr)))
454 (seq (cond ((not (equal now (cdr last))) 0)
455 ((< (car last) 99) (1+ (car last)))
456 (t (error "Run out of sequence numbers for ~A" name)))))
457 (safely-writing (out file)
458 (format out
459 ";; Serial number file for zone ~A~%~
b23c65ee
MW
460 ;; (LAST-SEQ DAY MONTH YEAR)~%~
461 ~S~%"
ab87c7bf
MW
462 name
463 (cons seq now)))
464 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
465
466;;;--------------------------------------------------------------------------
fe5fb85a 467;;; Zone form parsing.
7e282fb5 468
469(defun zone-parse-head (head)
f38bc59e
MW
470 "Parse the HEAD of a zone form.
471
472 This has the form
7e282fb5 473
474 (NAME &key :source :admin :refresh :retry
b23c65ee 475 :expire :min-ttl :ttl :serial)
7e282fb5 476
2f1d381d
MW
477 though a singleton NAME needn't be a list. Returns the default TTL and an
478 soa structure representing the zone head."
7e282fb5 479 (destructuring-bind
480 (zname
481 &key
8a4f9a18 482 (source *default-zone-source*)
7e282fb5 483 (admin (or *default-zone-admin*
484 (format nil "hostmaster@~A" zname)))
485 (refresh *default-zone-refresh*)
486 (retry *default-zone-retry*)
487 (expire *default-zone-expire*)
488 (min-ttl *default-zone-min-ttl*)
489 (ttl min-ttl)
490 (serial (make-zone-serial zname)))
491 (listify head)
492 (values zname
493 (timespec-seconds ttl)
494 (make-soa :admin admin
495 :source (zone-parse-host source zname)
496 :refresh (timespec-seconds refresh)
497 :retry (timespec-seconds retry)
498 :expire (timespec-seconds expire)
499 :min-ttl (timespec-seconds min-ttl)
500 :serial serial))))
501
afa2e2f1 502(export 'zone-make-name)
5bf80328 503(defun zone-make-name (prefix zone-name)
f4e0c48f
MW
504 "Compute a full domain name from a PREFIX and a ZONE-NAME.
505
506 If the PREFIX ends with `.' then it's absolute already; otherwise, append
507 the ZONE-NAME, separated with a `.'. If PREFIX is nil, or `@', then
508 return the ZONE-NAME only."
5bf80328
MW
509 (if (or (not prefix) (string= prefix "@"))
510 zone-name
511 (let ((len (length prefix)))
512 (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
513 (join-strings #\. (list prefix zone-name))
514 prefix))))
515
afa2e2f1 516(export 'defzoneparse)
7e282fb5 517(defmacro defzoneparse (types (name data list
5bf80328 518 &key (prefix (gensym "PREFIX"))
b23c65ee
MW
519 (zname (gensym "ZNAME"))
520 (ttl (gensym "TTL")))
7e282fb5 521 &body body)
f38bc59e
MW
522 "Define a new zone record type.
523
f4e0c48f
MW
524 The arguments are as follows:
525
526 TYPES A singleton type symbol, or a list of aliases.
fe5fb85a 527
2f1d381d 528 NAME The name of the record to be added.
fe5fb85a 529
2f1d381d 530 DATA The content of the record to be added (a single object,
7fff3797 531 unevaluated).
fe5fb85a 532
2f1d381d 533 LIST A function to add a record to the zone. See below.
fe5fb85a 534
5bf80328
MW
535 PREFIX The prefix tag used in the original form.
536
2f1d381d 537 ZNAME The name of the zone being constructed.
fe5fb85a 538
2f1d381d 539 TTL The TTL for this record.
fe5fb85a 540
5bf80328
MW
541 You get to choose your own names for these. ZNAME, PREFIX and TTL are
542 optional: you don't have to accept them if you're not interested.
fe5fb85a 543
2f1d381d
MW
544 The LIST argument names a function to be bound in the body to add a new
545 low-level record to the zone. It has the prototype
fe5fb85a 546
590ad961 547 (LIST &key :name :type :data :ttl :make-ptr-p)
fe5fb85a 548
590ad961
MW
549 These (except MAKE-PTR-P, which defaults to nil) default to the above
550 arguments (even if you didn't accept the arguments)."
7e282fb5 551 (setf types (listify types))
552 (let* ((type (car types))
553 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
2ec279f5 554 (with-parsed-body (body decls doc) body
590ad961 555 (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
40ded1b8
MW
556 `(progn
557 (dolist (,i ',types)
558 (setf (get ,i 'zone-parse) ',func))
5bf80328 559 (defun ,func (,prefix ,zname ,data ,ttl ,col)
40ded1b8
MW
560 ,@doc
561 ,@decls
5bf80328
MW
562 (let ((,name (zone-make-name ,prefix ,zname)))
563 (flet ((,list (&key ((:name ,tname) ,name)
564 ((:type ,ttype) ,type)
565 ((:data ,tdata) ,data)
590ad961
MW
566 ((:ttl ,tttl) ,ttl)
567 ((:make-ptr-p ,tmakeptrp) nil))
f4decf40 568 #+cmu (declare (optimize ext:inhibit-warnings))
5bf80328
MW
569 (collect (make-zone-record :name ,tname
570 :type ,ttype
571 :data ,tdata
590ad961
MW
572 :ttl ,tttl
573 :make-ptr-p ,tmakeptrp)
5bf80328
MW
574 ,col)))
575 ,@body)))
f4e0c48f 576 ',type)))))
7e282fb5 577
8fcf1ae3
MW
578(export 'zone-parse-records)
579(defun zone-parse-records (zname ttl records)
580 "Parse a sequence of RECORDS and return a list of raw records.
581
582 The records are parsed relative to the zone name ZNAME, and using the
583 given default TTL."
584 (collecting (rec)
585 (flet ((parse-record (zr)
586 (let ((func (or (get (zr-type zr) 'zone-parse)
587 (error "No parser for record ~A."
588 (zr-type zr))))
589 (name (and (zr-name zr) (stringify (zr-name zr)))))
590 (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
591 (zone-process-records records ttl #'parse-record))))
7e282fb5 592
afa2e2f1 593(export 'zone-parse)
7e282fb5 594(defun zone-parse (zf)
f38bc59e
MW
595 "Parse a ZONE form.
596
f4e0c48f 597 The syntax of a zone form is as follows:
7e282fb5 598
2f1d381d
MW
599 ZONE-FORM:
600 ZONE-HEAD ZONE-RECORD*
7e282fb5 601
2f1d381d
MW
602 ZONE-RECORD:
603 ((NAME*) ZONE-RECORD*)
604 | SYM ARGS"
7e282fb5 605 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
8fcf1ae3
MW
606 (make-zone :name zname
607 :default-ttl ttl
608 :soa soa
609 :records (zone-parse-records zname ttl (cdr zf)))))
7e282fb5 610
afa2e2f1 611(export 'zone-create)
fe5fb85a
MW
612(defun zone-create (zf)
613 "Zone construction function. Given a zone form ZF, construct the zone and
2f1d381d 614 add it to the table."
fe5fb85a
MW
615 (let* ((zone (zone-parse zf))
616 (name (zone-name zone)))
617 (setf (zone-find name) zone)
618 name))
619
afa2e2f1 620(export 'defzone)
fe5fb85a
MW
621(defmacro defzone (soa &rest zf)
622 "Zone definition macro."
623 `(zone-create '(,soa ,@zf)))
624
afa2e2f1 625(export 'defrevzone)
fe5fb85a
MW
626(defmacro defrevzone (head &rest zf)
627 "Define a reverse zone, with the correct name."
628 (destructuring-bind
629 (net &rest soa-args)
630 (listify head)
631 (let ((bytes nil))
632 (when (and soa-args (integerp (car soa-args)))
633 (setf bytes (pop soa-args)))
634 `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
635
636;;;--------------------------------------------------------------------------
637;;; Zone record parsers.
638
4e7e3780 639(defzoneparse :a (name data rec)
7e282fb5 640 ":a IPADDR"
590ad961
MW
641 (rec :data (parse-ipaddr data) :make-ptr-p t))
642
643(defzoneparse :svc (name data rec)
644 ":svc IPADDR"
645 (rec :type :a :data (parse-ipaddr data)))
fe5fb85a 646
7e282fb5 647(defzoneparse :ptr (name data rec :zname zname)
648 ":ptr HOST"
649 (rec :data (zone-parse-host data zname)))
fe5fb85a 650
7e282fb5 651(defzoneparse :cname (name data rec :zname zname)
652 ":cname HOST"
653 (rec :data (zone-parse-host data zname)))
fe5fb85a 654
90022a23
MW
655(defzoneparse :txt (name data rec)
656 ":txt TEXT"
657 (rec :data data))
658
f760c73a
MW
659(export '*dkim-pathname-defaults*)
660(defvar *dkim-pathname-defaults*
661 (make-pathname :directory '(:relative "keys")
662 :type "dkim"))
663
75f39e1a
MW
664(defzoneparse :dkim (name data rec)
665 ":dkim (KEYFILE {:TAG VALUE}*)"
666 (destructuring-bind (file &rest plist) (listify data)
667 (let ((things nil) (out nil))
668 (labels ((flush ()
669 (when out
670 (push (get-output-stream-string out) things)
671 (setf out nil)))
672 (emit (text)
673 (let ((len (length text)))
674 (when (and out (> (+ (file-position out)
675 (length text))
676 64))
677 (flush))
678 (when (plusp len)
679 (cond ((< len 64)
680 (unless out (setf out (make-string-output-stream)))
681 (write-string text out))
682 (t
683 (do ((i 0 j)
684 (j 64 (+ j 64)))
685 ((>= i len))
686 (push (subseq text i (min j len)) things))))))))
687 (do ((p plist (cddr p)))
688 ((endp p))
689 (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
690 (emit (with-output-to-string (out)
691 (write-string "p=" out)
692 (when file
f760c73a
MW
693 (with-open-file
694 (in (merge-pathnames file *dkim-pathname-defaults*))
75f39e1a
MW
695 (loop
696 (when (string= (read-line in)
697 "-----BEGIN PUBLIC KEY-----")
698 (return)))
699 (loop
700 (let ((line (read-line in)))
701 (if (string= line "-----END PUBLIC KEY-----")
702 (return)
703 (write-string line out)))))))))
704 (rec :type :txt
705 :data (nreverse things)))))
706
f1d7d492
MW
707(eval-when (:load-toplevel :execute)
708 (dolist (item '((sshfp-algorithm rsa 1)
709 (sshfp-algorithm dsa 2)
710 (sshfp-algorithm ecdsa 3)
711 (sshfp-type sha-1 1)
712 (sshfp-type sha-256 2)))
713 (destructuring-bind (prop sym val) item
714 (setf (get sym prop) val)
715 (export sym))))
716
f760c73a
MW
717(export '*sshfp-pathname-defaults*)
718(defvar *sshfp-pathname-defaults*
719 (make-pathname :directory '(:relative "keys")
720 :type "sshfp"))
721
f1d7d492
MW
722(defzoneparse :sshfp (name data rec)
723 ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
724 (if (stringp data)
f760c73a 725 (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
f1d7d492
MW
726 (loop (let ((line (read-line in nil)))
727 (unless line (return))
728 (let ((words (str-split-words line)))
729 (pop words)
730 (when (string= (car words) "IN") (pop words))
731 (unless (and (string= (car words) "SSHFP")
732 (= (length words) 4))
733 (error "Invalid SSHFP record."))
734 (pop words)
735 (destructuring-bind (alg type fpr) words
736 (rec :data (list (parse-integer alg)
737 (parse-integer type)
738 fpr)))))))
739 (flet ((lookup (what prop)
740 (etypecase what
741 (fixnum what)
742 (symbol (or (get what prop)
743 (error "~S is not a known ~A" what prop))))))
48608192
MW
744 (dolist (item (listify data))
745 (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
746 (listify item)
747 (rec :data (list (lookup alg 'sshfp-algorithm)
748 (lookup type 'sshfp-type)
749 fpr)))))))
f1d7d492 750
7e282fb5 751(defzoneparse :mx (name data rec :zname zname)
752 ":mx ((HOST :prio INT :ip IPADDR)*)"
753 (dolist (mx (listify data))
754 (destructuring-bind
755 (mxname &key (prio *default-mx-priority*) ip)
756 (listify mx)
757 (let ((host (zone-parse-host mxname zname)))
758 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
759 (rec :data (cons host prio))))))
fe5fb85a 760
7e282fb5 761(defzoneparse :ns (name data rec :zname zname)
762 ":ns ((HOST :ip IPADDR)*)"
763 (dolist (ns (listify data))
764 (destructuring-bind
765 (nsname &key ip)
766 (listify ns)
767 (let ((host (zone-parse-host nsname zname)))
768 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
769 (rec :data host)))))
fe5fb85a 770
7e282fb5 771(defzoneparse :alias (name data rec :zname zname)
772 ":alias (LABEL*)"
773 (dolist (a (listify data))
774 (rec :name (zone-parse-host a zname)
775 :type :cname
776 :data name)))
fe5fb85a 777
716105aa
MW
778(defzoneparse :srv (name data rec :zname zname)
779 ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
780 (dolist (srv data)
781 (destructuring-bind (servopts &rest providers) srv
782 (destructuring-bind
783 (service &key ((:port default-port)) (protocol :tcp))
784 (listify servopts)
785 (unless default-port
786 (let ((serv (serv-by-name service protocol)))
787 (setf default-port (and serv (serv-port serv)))))
788 (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
789 (dolist (prov providers)
790 (destructuring-bind
791 (srvname
792 &key
793 (port default-port)
794 (prio *default-mx-priority*)
795 (weight 0)
796 ip)
797 (listify prov)
798 (let ((host (zone-parse-host srvname zname)))
799 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
800 (rec :name rname
801 :data (list prio weight port host))))))))))
802
a15288b4 803(defzoneparse :net (name data rec)
804 ":net (NETWORK*)"
805 (dolist (net (listify data))
806 (let ((n (net-get-as-ipnet net)))
807 (rec :name (zone-parse-host "net" name)
808 :type :a
809 :data (ipnet-net n))
810 (rec :name (zone-parse-host "mask" name)
811 :type :a
812 :data (ipnet-mask n))
098b57a2 813 (rec :name (zone-parse-host "bcast" name)
a15288b4 814 :type :a
815 :data (ipnet-broadcast n)))))
7fff3797 816
7e282fb5 817(defzoneparse (:rev :reverse) (name data rec)
679775ba
MW
818 ":reverse ((NET :bytes BYTES) ZONE*)
819
820 Add a reverse record each host in the ZONEs (or all zones) that lies
821 within NET. The BYTES give the number of prefix labels generated; this
822 defaults to the smallest number of bytes needed to enumerate the net."
7e282fb5 823 (setf data (listify data))
cc0fa47a 824 (destructuring-bind (net &key bytes) (listify (car data))
7e282fb5 825 (setf net (zone-parse-net net name))
826 (unless bytes
827 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
4e7e3780
MW
828 (let ((seen (make-hash-table :test #'equal)))
829 (dolist (z (or (cdr data)
830 (hash-table-keys *zones*)))
831 (dolist (zr (zone-records (zone-find z)))
832 (when (and (eq (zr-type zr) :a)
590ad961 833 (zr-make-ptr-p zr)
4e7e3780
MW
834 (ipaddr-networkp (zr-data zr) net))
835 (let ((name (string-downcase
836 (join-strings
837 #\.
838 (collecting ()
839 (dotimes (i bytes)
840 (collect (logand #xff (ash (zr-data zr)
841 (* -8 i)))))
842 (collect name))))))
843 (unless (gethash name seen)
844 (rec :name name :type :ptr
845 :ttl (zr-ttl zr) :data (zr-name zr))
846 (setf (gethash name seen) t)))))))))
7e282fb5 847
cc0fa47a 848(defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
679775ba
MW
849 ":cidr-delegation ((NET :bytes BYTES) ((TARGET-NET*) [TARGET-ZONE])*)
850
851 Insert CNAME records for delegating a portion of the reverse-lookup
852 namespace which doesn't align with an octet boundary.
853
854 The NET specifies the origin network, in which the reverse records
855 naturally lie. The BYTES are the number of labels to supply for each
856 address; the default is the smallest number which suffices to enumerate
857 the entire NET. The TARGET-NETs are subnets of NET which are to be
858 delegated. The TARGET-ZONEs are the zones to which we are delegating
859 authority for the reverse records: the default is to append labels for those
860 octets of the subnet base address which are not the same in all address in
861 the subnet."
cc0fa47a
MW
862 (setf data (listify data))
863 (destructuring-bind (net &key bytes) (listify (car data))
7e282fb5 864 (setf net (zone-parse-net net name))
865 (unless bytes
866 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
cc0fa47a 867 (dolist (map (or (cdr data) (list (list net))))
4440be0d
MW
868 (destructuring-bind (tnets &optional tdom) (listify map)
869 (dolist (tnet (listify tnets))
870 (setf tnet (zone-parse-net tnet name))
871 (unless (ipnet-subnetp net tnet)
872 (error "~A is not a subnet of ~A."
873 (ipnet-pretty tnet)
874 (ipnet-pretty net)))
875 (unless tdom
876 (with-ipnet (net mask) tnet
877 (setf tdom
878 (join-strings
879 #\.
880 (append (reverse (loop
881 for i from (1- bytes) downto 0
882 until (zerop (logand mask
883 (ash #xff
884 (* 8 i))))
885 collect (ldb (byte 8 (* i 8)) net)))
886 (list name))))))
887 (setf tdom (string-downcase (stringify tdom)))
888 (dotimes (i (ipnet-hosts tnet))
889 (unless (zerop i)
890 (let* ((addr (ipnet-host tnet i))
891 (tail (join-strings #\.
892 (loop
893 for i from 0 below bytes
894 collect
895 (logand #xff
896 (ash addr (* 8 i)))))))
897 (rec :name (format nil "~A.~A" tail name)
898 :type :cname
899 :data (format nil "~A.~A" tail tdom))))))))))
7e282fb5 900
fe5fb85a
MW
901;;;--------------------------------------------------------------------------
902;;; Zone file output.
7e282fb5 903
afa2e2f1 904(export 'zone-write)
a567a3bc
MW
905(defgeneric zone-write (format zone stream)
906 (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
907
908(defvar *writing-zone* nil
909 "The zone currently being written.")
910
911(defvar *zone-output-stream* nil
912 "Stream to write zone data on.")
913
914(defmethod zone-write :around (format zone stream)
b68068e3 915 (declare (ignore format))
a567a3bc
MW
916 (let ((*writing-zone* zone)
917 (*zone-output-stream* stream))
918 (call-next-method)))
919
afa2e2f1 920(export 'zone-save)
a567a3bc
MW
921(defun zone-save (zones &key (format :bind))
922 "Write the named ZONES to files. If no zones are given, write all the
923 zones."
924 (unless zones
925 (setf zones (hash-table-keys *zones*)))
926 (safely (safe)
927 (dolist (z zones)
928 (let ((zz (zone-find z)))
929 (unless zz
930 (error "Unknown zone `~A'." z))
931 (let ((stream (safely-open-output-stream safe
932 (zone-file-name z :zone))))
933 (zone-write format zz stream))))))
934
935;;;--------------------------------------------------------------------------
936;;; Bind format output.
937
afa2e2f1 938(export 'bind-hostname)
a567a3bc
MW
939(defun bind-hostname (hostname)
940 (if (not hostname)
941 "@"
942 (let* ((h (string-downcase (stringify hostname)))
943 (hl (length h))
944 (r (string-downcase (zone-name *writing-zone*)))
945 (rl (length r)))
946 (cond ((string= r h) "@")
947 ((and (> hl rl)
948 (char= (char h (- hl rl 1)) #\.)
949 (string= h r :start1 (- hl rl)))
950 (subseq h 0 (- hl rl 1)))
951 (t (concatenate 'string h "."))))))
952
953(defmethod zone-write ((format (eql :bind)) zone stream)
954 (format stream "~
7e282fb5 955;;; Zone file `~(~A~)'
956;;; (generated ~A)
957
7d593efd
MW
958$ORIGIN ~0@*~(~A.~)
959$TTL ~2@*~D~2%"
7e282fb5 960 (zone-name zone)
961 (iso-date :now :datep t :timep t)
962 (zone-default-ttl zone))
a567a3bc
MW
963 (let* ((soa (zone-soa zone))
964 (admin (let* ((name (soa-admin soa))
965 (at (position #\@ name))
966 (copy (format nil "~(~A~)." name)))
967 (when at
968 (setf (char copy at) #\.))
969 copy)))
7e282fb5 970 (format stream "~
971~A~30TIN SOA~40T~A ~A (
972~45T~10D~60T ;serial
973~45T~10D~60T ;refresh
974~45T~10D~60T ;retry
975~45T~10D~60T ;expire
976~45T~10D )~60T ;min-ttl~2%"
a567a3bc
MW
977 (bind-hostname (zone-name zone))
978 (bind-hostname (soa-source soa))
979 admin
7e282fb5 980 (soa-serial soa)
981 (soa-refresh soa)
982 (soa-retry soa)
983 (soa-expire soa)
984 (soa-min-ttl soa)))
a567a3bc
MW
985 (dolist (zr (zone-records zone))
986 (bind-record (zr-type zr) zr)))
987
afa2e2f1 988(export 'bind-record)
a567a3bc
MW
989(defgeneric bind-record (type zr))
990
afa2e2f1 991(export 'bind-format-record)
a567a3bc
MW
992(defun bind-format-record (name ttl type format args)
993 (format *zone-output-stream*
994 "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
995 (bind-hostname name)
996 (and (/= ttl (zone-default-ttl *writing-zone*))
997 ttl)
998 (string-upcase (symbol-name type))
999 format args))
1000
1001(defmethod bind-record (type zr)
1002 (destructuring-bind (format &rest args)
1003 (bind-record-format-args type (zr-data zr))
1004 (bind-format-record (zr-name zr)
1005 (zr-ttl zr)
1006 (bind-record-type type)
1007 format args)))
1008
afa2e2f1 1009(export 'bind-record-type)
a567a3bc
MW
1010(defgeneric bind-record-type (type)
1011 (:method (type) type))
1012
afa2e2f1 1013(export 'bind-record-format-args)
a567a3bc
MW
1014(defgeneric bind-record-format-args (type data)
1015 (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
1016 (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
1017 (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
1018 (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
1019 (:method ((type (eql :mx)) data)
1020 (list "~2D ~A" (cdr data) (bind-hostname (car data))))
716105aa
MW
1021 (:method ((type (eql :srv)) data)
1022 (destructuring-bind (prio weight port host) data
1023 (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
f1d7d492
MW
1024 (:method ((type (eql :sshfp)) data)
1025 (cons "~2D ~2D ~A" data))
9d1d9739
MW
1026 (:method ((type (eql :txt)) data)
1027 (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
1028 (mapcar #'stringify (listify data)))))
7e282fb5 1029
1030;;;----- That's all, folks --------------------------------------------------