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