chiark / gitweb /
zone.lisp: Include SSHFP type code for Ed25519 keys.
[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
2d8313b9
MW
38(export '*zone-config*)
39(defparameter *zone-config* nil
40 "A list of configuration variables.
41
42 This is for the benefit of the frontend, which will dynamically bind them
43 so that input files can override them independently. Not intended for use
44 by users.")
45
fe5fb85a
MW
46(defun to-integer (x)
47 "Convert X to an integer in the most straightforward way."
48 (floor (rational x)))
49
50(defun from-mixed-base (base val)
51 "BASE is a list of the ranges for the `digits' of a mixed-base
2f1d381d 52 representation. Convert VAL, a list of digits, into an integer."
fe5fb85a
MW
53 (do ((base base (cdr base))
54 (val (cdr val) (cdr val))
55 (a (car val) (+ (* a (car base)) (car val))))
56 ((or (null base) (null val)) a)))
57
58(defun to-mixed-base (base val)
59 "BASE is a list of the ranges for the `digits' of a mixed-base
2f1d381d 60 representation. Convert VAL, an integer, into a list of digits."
fe5fb85a
MW
61 (let ((base (reverse base))
62 (a nil))
63 (loop
64 (unless base
65 (push val a)
66 (return a))
67 (multiple-value-bind (q r) (floor val (pop base))
68 (push r a)
69 (setf val q)))))
70
afa2e2f1 71(export 'timespec-seconds)
fe5fb85a 72(defun timespec-seconds (ts)
f38bc59e
MW
73 "Convert a timespec TS to seconds.
74
f4e0c48f 75 A timespec may be a real count of seconds, or a list (COUNT UNIT). UNIT
f38bc59e 76 may be any of a number of obvious time units."
fe5fb85a
MW
77 (cond ((null ts) 0)
78 ((realp ts) (floor ts))
79 ((atom ts)
80 (error "Unknown timespec format ~A" ts))
81 ((null (cdr ts))
82 (timespec-seconds (car ts)))
83 (t (+ (to-integer (* (car ts)
84 (case (intern (string-upcase
85 (stringify (cadr ts)))
86 '#:zone)
87 ((s sec secs second seconds) 1)
88 ((m min mins minute minutes) 60)
89 ((h hr hrs hour hours) #.(* 60 60))
90 ((d dy dys day days) #.(* 24 60 60))
91 ((w wk wks week weeks) #.(* 7 24 60 60))
92 ((y yr yrs year years) #.(* 365 24 60 60))
93 (t (error "Unknown time unit ~A"
94 (cadr ts))))))
95 (timespec-seconds (cddr ts))))))
96
97(defun hash-table-keys (ht)
98 "Return a list of the keys in hashtable HT."
99 (collecting ()
100 (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
101
102(defun iso-date (&optional time &key datep timep (sep #\ ))
f38bc59e
MW
103 "Construct a textual date or time in ISO format.
104
105 The TIME is the universal time to convert, which defaults to now; DATEP is
106 whether to emit the date; TIMEP is whether to emit the time, and
107 SEP (default is space) is how to separate the two."
fe5fb85a
MW
108 (multiple-value-bind
109 (sec min hr day mon yr dow dstp tz)
110 (decode-universal-time (if (or (null time) (eq time :now))
111 (get-universal-time)
112 time))
113 (declare (ignore dow dstp tz))
114 (with-output-to-string (s)
115 (when datep
116 (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
117 (when timep
118 (write-char sep s)))
119 (when timep
120 (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
121
2c446779
MW
122(deftype octet () '(unsigned-byte 8))
123(deftype octet-vector (&optional n) `(array octet (,n)))
124
125(defun decode-hex (hex &key (start 0) end)
126 "Decode a hexadecimal-encoded string, returning a vector of octets."
127 (let* ((end (or end (length hex)))
128 (len (- end start))
129 (raw (make-array (floor len 2) :element-type 'octet)))
130 (unless (evenp len)
131 (error "Invalid hex string `~A' (odd length)" hex))
132 (do ((i start (+ i 2)))
133 ((>= i end) raw)
134 (let ((high (digit-char-p (char hex i) 16))
135 (low (digit-char-p (char hex (1+ i)) 16)))
136 (unless (and high low)
137 (error "Invalid hex string `~A' (bad digit)" hex))
138 (setf (aref raw (/ (- i start) 2)) (+ (* 16 high) low))))))
139
140(defun slurp-file (file &optional (element-type 'character))
141 "Read and return the contents of FILE as a vector."
142 (with-open-file (in file :element-type element-type)
143 (let ((buf (make-array 1024 :element-type element-type))
144 (pos 0))
145 (loop
146 (let ((end (read-sequence buf in :start pos)))
147 (when (< end (length buf))
148 (return (adjust-array buf end)))
149 (setf pos end
150 buf (adjust-array buf (* 2 pos))))))))
151
5952892a
MW
152(defmacro defenum (name (&key export) &body values)
153 "Set up symbol properties for manifest constants.
154
155 The VALUES are a list of (TAG VALUE) pairs. Each TAG is a symbol; we set
156 the NAME property on TAG to VALUE, and export TAG. There are also handy
157 hash-tables mapping in the forward and reverse directions, in the name
158 symbol's `enum-forward' and `enum-reverse' properties."
159 `(eval-when (:compile-toplevel :load-toplevel :execute)
160 ,(let*/gensyms (export)
161 (with-gensyms (forward reverse valtmp)
162 `(let ((,forward (make-hash-table))
163 (,reverse (make-hash-table)))
164 (when ,export (export ',name))
165 ,@(mapcar (lambda (item)
166 (destructuring-bind (tag value) item
167 (let ((constant
168 (intern (concatenate 'string
169 (symbol-name name)
170 "/"
171 (symbol-name tag)))))
172 `(let ((,valtmp ,value))
173 (when ,export
174 (export ',constant)
175 (when (eq (symbol-package ',tag) *package*)
176 (export ',tag)))
177 (defconstant ,constant ,valtmp)
178 (setf (get ',tag ',name) ,value
179 (gethash ',tag ,forward) ,valtmp
180 (gethash ,valtmp ,reverse) ',tag)))))
181 values)
182 (setf (get ',name 'enum-forward) ,forward
183 (get ',name 'enum-reverse) ,reverse))))))
184
185(defun lookup-enum (name tag &key min max)
186 "Look up a TAG in an enumeration.
187
188 If TAG is a symbol, check its NAME property; if it's a fixnum then take it
189 as it is. Make sure that it's between MIN and MAX, if they're not nil."
190 (let ((value (etypecase tag
191 (fixnum tag)
192 (symbol (or (get tag name)
193 (error "~S is not a known ~A" tag name))))))
194 (unless (and (or (null min) (<= min value))
195 (or (null max) (<= value max)))
196 (error "Value ~S out of range for ~A" value name))
197 value))
198
199(defun reverse-enum (name value)
200 "Reverse-lookup of a VALUE in enumeration NAME.
201
202 If a tag for the VALUE is found, return it and `t'; otherwise return VALUE
203 unchanged and `nil'."
204 (multiple-value-bind (tag foundp) (gethash value (get name 'enum-reverse))
205 (if foundp
206 (values tag t)
207 (values value nil))))
208
209(defun mapenum (func name)
210 "Call FUNC on TAG/VALUE pairs from the enumeration called NAME."
211 (maphash func (get name 'enum-forward)))
212
476808d8
MW
213(defun hash-file (hash file context)
214 "Hash the FILE using the OpenSSL HASH function, returning an octet string.
215
216 CONTEXT is a temporary-files context."
217 (let ((temp (temporary-file context "hash")))
218 (run-program (list "openssl" "dgst" (concatenate 'string "-" hash))
219 :input file :output temp)
220 (with-open-file (in temp)
221 (let ((line (read-line in)))
222 (assert (and (>= (length line) 9)
223 (string= line "(stdin)= " :end1 9)))
224 (decode-hex line :start 9)))))
225
fe5fb85a
MW
226;;;--------------------------------------------------------------------------
227;;; Zone types.
7e282fb5 228
afa2e2f1 229(export 'soa)
7e282fb5 230(defstruct (soa (:predicate soap))
231 "Start-of-authority record information."
232 source
233 admin
234 refresh
235 retry
236 expire
237 min-ttl
238 serial)
fe5fb85a 239
db43369d
MW
240(export 'zone-text-name)
241(defun zone-text-name (zone)
242 (princ-to-string (zone-name zone)))
243
afa2e2f1 244(export 'mx)
7e282fb5 245(defstruct (mx (:predicate mxp))
246 "Mail-exchange record information."
247 priority
248 domain)
fe5fb85a 249
afa2e2f1 250(export 'zone)
7e282fb5 251(defstruct (zone (:predicate zonep))
252 "Zone information."
253 soa
254 default-ttl
255 name
256 records)
257
fe5fb85a
MW
258;;;--------------------------------------------------------------------------
259;;; Zone defaults. It is intended that scripts override these.
260
afa2e2f1 261(export '*default-zone-source*)
7e282fb5 262(defvar *default-zone-source*
8e7c1366 263 (let ((hn (gethostname)))
8a4f9a18 264 (and hn (concatenate 'string (canonify-hostname hn) ".")))
7e282fb5 265 "The default zone source: the current host's name.")
fe5fb85a 266
afa2e2f1 267(export '*default-zone-refresh*)
7e282fb5 268(defvar *default-zone-refresh* (* 24 60 60)
269 "Default zone refresh interval: one day.")
fe5fb85a 270
afa2e2f1 271(export '*default-zone-admin*)
7e282fb5 272(defvar *default-zone-admin* nil
273 "Default zone administrator's email address.")
fe5fb85a 274
afa2e2f1 275(export '*default-zone-retry*)
7e282fb5 276(defvar *default-zone-retry* (* 60 60)
277 "Default znoe retry interval: one hour.")
fe5fb85a 278
afa2e2f1 279(export '*default-zone-expire*)
7e282fb5 280(defvar *default-zone-expire* (* 14 24 60 60)
281 "Default zone expiry time: two weeks.")
fe5fb85a 282
afa2e2f1 283(export '*default-zone-min-ttl*)
7e282fb5 284(defvar *default-zone-min-ttl* (* 4 60 60)
285 "Default zone minimum TTL/negative TTL: four hours.")
fe5fb85a 286
afa2e2f1 287(export '*default-zone-ttl*)
7e282fb5 288(defvar *default-zone-ttl* (* 8 60 60)
289 "Default zone TTL (for records without explicit TTLs): 8 hours.")
fe5fb85a 290
afa2e2f1 291(export '*default-mx-priority*)
7e282fb5 292(defvar *default-mx-priority* 50
293 "Default MX priority.")
294
fe5fb85a 295;;;--------------------------------------------------------------------------
fe5fb85a
MW
296;;; Zone variables and structures.
297
7e282fb5 298(defvar *zones* (make-hash-table :test #'equal)
299 "Map of known zones.")
fe5fb85a 300
afa2e2f1 301(export 'zone-find)
7e282fb5 302(defun zone-find (name)
303 "Find a zone given its NAME."
304 (gethash (string-downcase (stringify name)) *zones*))
305(defun (setf zone-find) (zone name)
306 "Make the zone NAME map to ZONE."
307 (setf (gethash (string-downcase (stringify name)) *zones*) zone))
308
afa2e2f1 309(export 'zone-record)
7e282fb5 310(defstruct (zone-record (:conc-name zr-))
311 "A zone record."
312 (name '<unnamed>)
313 ttl
314 type
590ad961 315 (make-ptr-p nil)
7e282fb5 316 data)
317
afa2e2f1 318(export 'zone-subdomain)
7e282fb5 319(defstruct (zone-subdomain (:conc-name zs-))
f4e0c48f
MW
320 "A subdomain.
321
322 Slightly weird. Used internally by `zone-process-records', and shouldn't
323 escape."
7e282fb5 324 name
325 ttl
326 records)
327
afa2e2f1 328(export '*zone-output-path*)
3d7852d9
MW
329(defvar *zone-output-path* nil
330 "Pathname defaults to merge into output files.
331
332 If this is nil then use the prevailing `*default-pathname-defaults*'.
333 This is not the same as capturing the `*default-pathname-defaults*' from
334 load time.")
ab87c7bf 335
afa2e2f1 336(export '*preferred-subnets*)
8ce7eb9b
MW
337(defvar *preferred-subnets* nil
338 "Subnets to prefer when selecting defaults.")
339
fe5fb85a
MW
340;;;--------------------------------------------------------------------------
341;;; Zone infrastructure.
342
ab87c7bf
MW
343(defun zone-file-name (zone type)
344 "Choose a file name for a given ZONE and TYPE."
345 (merge-pathnames (make-pathname :name (string-downcase zone)
346 :type (string-downcase type))
3d7852d9 347 (or *zone-output-path* *default-pathname-defaults*)))
ab87c7bf 348
afa2e2f1 349(export 'zone-preferred-subnet-p)
8ce7eb9b
MW
350(defun zone-preferred-subnet-p (name)
351 "Answer whether NAME (a string or symbol) names a preferred subnet."
352 (member name *preferred-subnets* :test #'string-equal))
353
afa2e2f1 354(export 'preferred-subnet-case)
8bd2576e 355(defmacro preferred-subnet-case (&body clauses)
f4e0c48f 356 "Execute a form based on which networks are considered preferred.
f38bc59e 357
f4e0c48f
MW
358 The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
359 whose SUBNETS (a list or single symbol, not evaluated) are listed in
360 `*preferred-subnets*'. If SUBNETS is the symbol `t' then the clause
361 always matches."
8bd2576e
MW
362 `(cond
363 ,@(mapcar (lambda (clause)
364 (let ((subnets (car clause)))
365 (cons (cond ((eq subnets t)
366 t)
367 ((listp subnets)
368 `(or ,@(mapcar (lambda (subnet)
369 `(zone-preferred-subnet-p
370 ',subnet))
371 subnets)))
372 (t
373 `(zone-preferred-subnet-p ',subnets)))
374 (cdr clause))))
375 clauses)))
376
32ebbe9b 377(export 'zone-parse-host)
db43369d
MW
378(defun zone-parse-host (form &optional tail)
379 "Parse a host name FORM from a value in a zone form.
380
381 The underlying parsing is done using `parse-domain-name'. Here, we
382 interpret various kinds of Lisp object specially. In particular: `nil'
383 refers to the TAIL zone (just like a plain `@'); and a symbol is downcased
384 before use."
385 (let ((name (etypecase form
386 (null (make-domain-name :labels nil :absolutep nil))
387 (domain-name form)
388 (symbol (parse-domain-name (string-downcase form)))
389 (string (parse-domain-name form)))))
390 (if (null tail) name
391 (domain-name-concat name tail))))
32ebbe9b 392
aac45ff7
MW
393(export 'zone-records-sorted)
394(defun zone-records-sorted (zone)
395 "Return the ZONE's records, in a pleasant sorted order."
396 (sort (copy-seq (zone-records zone))
397 (lambda (zr-a zr-b)
05e83012
MW
398 (multiple-value-bind (precp follp)
399 (domain-name< (zr-name zr-a) (zr-name zr-b))
400 (cond (precp t)
401 (follp nil)
402 (t (string< (zr-type zr-a) (zr-type zr-b))))))))
aac45ff7 403
32ebbe9b
MW
404;;;--------------------------------------------------------------------------
405;;; Serial numbering.
406
407(export 'make-zone-serial)
408(defun make-zone-serial (name)
409 "Given a zone NAME, come up with a new serial number.
410
411 This will (very carefully) update a file ZONE.serial in the current
412 directory."
413 (let* ((file (zone-file-name name :serial))
414 (last (with-open-file (in file
415 :direction :input
416 :if-does-not-exist nil)
417 (if in (read in)
418 (list 0 0 0 0))))
419 (now (multiple-value-bind
420 (sec min hr dy mon yr dow dstp tz)
421 (get-decoded-time)
422 (declare (ignore sec min hr dow dstp tz))
423 (list dy mon yr)))
424 (seq (cond ((not (equal now (cdr last))) 0)
425 ((< (car last) 99) (1+ (car last)))
426 (t (error "Run out of sequence numbers for ~A" name)))))
427 (safely-writing (out file)
428 (format out
429 ";; Serial number file for zone ~A~%~
430 ;; (LAST-SEQ DAY MONTH YEAR)~%~
431 ~S~%"
432 name
433 (cons seq now)))
434 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
435
436;;;--------------------------------------------------------------------------
437;;; Zone form parsing.
438
7e282fb5 439(defun zone-process-records (rec ttl func)
f38bc59e
MW
440 "Sort out the list of records in REC, calling FUNC for each one.
441
baad8564
MW
442 TTL is the default time-to-live for records which don't specify one.
443
f4e0c48f
MW
444 REC is a list of records of the form
445
446 ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)
447
448 The various kinds of entries have the following meanings.
449
450 :ttl TTL Set the TTL for subsequent records (at this level of
451 nesting only).
452
453 TYPE DATA Define a record with a particular TYPE and DATA.
454 Record types are defined using `defzoneparse' and
455 the syntax of the data is idiosyncratic.
456
457 ((LABEL ...) . REC) Define records for labels within the zone. Any
458 records defined within REC will have their domains
459 prefixed by each of the LABELs. A singleton list
460 of labels may instead be written as a single
461 label. Note, therefore, that
462
463 (host (sub :a \"169.254.1.1\"))
baad8564 464
f4e0c48f 465 defines a record for `host.sub' -- not `sub.host'.
baad8564 466
f4e0c48f
MW
467 If REC contains no top-level records, but it does define records for a
468 label listed in `*preferred-subnets*', then the records for the first such
469 label are also promoted to top-level.
baad8564 470
f4e0c48f
MW
471 The FUNC is called for each record encountered, represented as a
472 `zone-record' object. Zone parsers are not called: you get the record
473 types and data from the input form; see `zone-parse-records' if you want
474 the raw output."
baad8564 475
7e282fb5 476 (labels ((sift (rec ttl)
f4e0c48f
MW
477 ;; Parse the record list REC into lists of `zone-record' and
478 ;; `zone-subdomain' objects, sorting out TTLs and so on.
479 ;; Returns them as two values.
480
7e282fb5 481 (collecting (top sub)
482 (loop
483 (unless rec
484 (return))
485 (let ((r (pop rec)))
486 (cond ((eq r :ttl)
487 (setf ttl (pop rec)))
488 ((symbolp r)
489 (collect (make-zone-record :type r
490 :ttl ttl
491 :data (pop rec))
492 top))
493 ((listp r)
494 (dolist (name (listify (car r)))
db43369d
MW
495 (collect (make-zone-subdomain
496 :name (zone-parse-host name)
497 :ttl ttl :records (cdr r))
7e282fb5 498 sub)))
499 (t
500 (error "Unexpected record form ~A" (car r))))))))
f4e0c48f 501
4e7e3780 502 (process (rec dom ttl)
f4e0c48f
MW
503 ;; Recursirvely process the record list REC, with a list DOM of
504 ;; prefix labels, and a default TTL. Promote records for a
505 ;; preferred subnet to toplevel if there are no toplevel records
506 ;; already.
507
7e282fb5 508 (multiple-value-bind (top sub) (sift rec ttl)
509 (if (and dom (null top) sub)
64e34a97 510 (let ((preferred
db43369d
MW
511 (or (find-if
512 (lambda (s)
513 (let ((ll (domain-name-labels (zs-name s))))
514 (and (consp ll) (null (cdr ll))
515 (zone-preferred-subnet-p (car ll)))))
516 sub)
64e34a97 517 (car sub))))
8ce7eb9b
MW
518 (when preferred
519 (process (zs-records preferred)
520 dom
521 (zs-ttl preferred))))
db43369d 522 (let ((name dom))
8ce7eb9b
MW
523 (dolist (zr top)
524 (setf (zr-name zr) name)
525 (funcall func zr))))
7e282fb5 526 (dolist (s sub)
527 (process (zs-records s)
db43369d
MW
528 (if (null dom) (zs-name s)
529 (domain-name-concat dom (zs-name s)))
4e7e3780 530 (zs-ttl s))))))
f4e0c48f
MW
531
532 ;; Process the records we're given with no prefix.
4e7e3780 533 (process rec nil ttl)))
7e282fb5 534
7e282fb5 535(defun zone-parse-head (head)
f38bc59e
MW
536 "Parse the HEAD of a zone form.
537
538 This has the form
7e282fb5 539
540 (NAME &key :source :admin :refresh :retry
b23c65ee 541 :expire :min-ttl :ttl :serial)
7e282fb5 542
2f1d381d
MW
543 though a singleton NAME needn't be a list. Returns the default TTL and an
544 soa structure representing the zone head."
7e282fb5 545 (destructuring-bind
db43369d 546 (raw-zname
7e282fb5 547 &key
8a4f9a18 548 (source *default-zone-source*)
7e282fb5 549 (admin (or *default-zone-admin*
db43369d 550 (format nil "hostmaster@~A" raw-zname)))
7e282fb5 551 (refresh *default-zone-refresh*)
552 (retry *default-zone-retry*)
553 (expire *default-zone-expire*)
554 (min-ttl *default-zone-min-ttl*)
555 (ttl min-ttl)
db43369d
MW
556 (serial (make-zone-serial raw-zname))
557 &aux
558 (zname (zone-parse-host raw-zname root-domain)))
7e282fb5 559 (listify head)
db43369d 560 (values zname
7e282fb5 561 (timespec-seconds ttl)
562 (make-soa :admin admin
563 :source (zone-parse-host source zname)
564 :refresh (timespec-seconds refresh)
565 :retry (timespec-seconds retry)
566 :expire (timespec-seconds expire)
567 :min-ttl (timespec-seconds min-ttl)
568 :serial serial))))
569
afa2e2f1 570(export 'defzoneparse)
7e282fb5 571(defmacro defzoneparse (types (name data list
5bf80328 572 &key (prefix (gensym "PREFIX"))
b23c65ee
MW
573 (zname (gensym "ZNAME"))
574 (ttl (gensym "TTL")))
7e282fb5 575 &body body)
f38bc59e
MW
576 "Define a new zone record type.
577
f4e0c48f
MW
578 The arguments are as follows:
579
580 TYPES A singleton type symbol, or a list of aliases.
fe5fb85a 581
2f1d381d 582 NAME The name of the record to be added.
fe5fb85a 583
2f1d381d 584 DATA The content of the record to be added (a single object,
7fff3797 585 unevaluated).
fe5fb85a 586
2f1d381d 587 LIST A function to add a record to the zone. See below.
fe5fb85a 588
5bf80328
MW
589 PREFIX The prefix tag used in the original form.
590
2f1d381d 591 ZNAME The name of the zone being constructed.
fe5fb85a 592
2f1d381d 593 TTL The TTL for this record.
fe5fb85a 594
5bf80328
MW
595 You get to choose your own names for these. ZNAME, PREFIX and TTL are
596 optional: you don't have to accept them if you're not interested.
fe5fb85a 597
2f1d381d
MW
598 The LIST argument names a function to be bound in the body to add a new
599 low-level record to the zone. It has the prototype
fe5fb85a 600
590ad961 601 (LIST &key :name :type :data :ttl :make-ptr-p)
fe5fb85a 602
590ad961
MW
603 These (except MAKE-PTR-P, which defaults to nil) default to the above
604 arguments (even if you didn't accept the arguments)."
db43369d 605
7e282fb5 606 (setf types (listify types))
607 (let* ((type (car types))
608 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
2ec279f5 609 (with-parsed-body (body decls doc) body
590ad961 610 (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
40ded1b8
MW
611 `(progn
612 (dolist (,i ',types)
613 (setf (get ,i 'zone-parse) ',func))
5bf80328 614 (defun ,func (,prefix ,zname ,data ,ttl ,col)
40ded1b8
MW
615 ,@doc
616 ,@decls
db43369d
MW
617 (let ((,name (if (null ,prefix) ,zname
618 (domain-name-concat ,prefix ,zname))))
5bf80328
MW
619 (flet ((,list (&key ((:name ,tname) ,name)
620 ((:type ,ttype) ,type)
621 ((:data ,tdata) ,data)
590ad961
MW
622 ((:ttl ,tttl) ,ttl)
623 ((:make-ptr-p ,tmakeptrp) nil))
f4decf40 624 #+cmu (declare (optimize ext:inhibit-warnings))
5bf80328
MW
625 (collect (make-zone-record :name ,tname
626 :type ,ttype
627 :data ,tdata
590ad961
MW
628 :ttl ,tttl
629 :make-ptr-p ,tmakeptrp)
5bf80328
MW
630 ,col)))
631 ,@body)))
f4e0c48f 632 ',type)))))
7e282fb5 633
8fcf1ae3
MW
634(export 'zone-parse-records)
635(defun zone-parse-records (zname ttl records)
636 "Parse a sequence of RECORDS and return a list of raw records.
637
638 The records are parsed relative to the zone name ZNAME, and using the
639 given default TTL."
640 (collecting (rec)
641 (flet ((parse-record (zr)
642 (let ((func (or (get (zr-type zr) 'zone-parse)
643 (error "No parser for record ~A."
644 (zr-type zr))))
db43369d 645 (name (and (zr-name zr) (zr-name zr))))
8fcf1ae3
MW
646 (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
647 (zone-process-records records ttl #'parse-record))))
7e282fb5 648
afa2e2f1 649(export 'zone-parse)
7e282fb5 650(defun zone-parse (zf)
f38bc59e
MW
651 "Parse a ZONE form.
652
f4e0c48f 653 The syntax of a zone form is as follows:
7e282fb5 654
2f1d381d
MW
655 ZONE-FORM:
656 ZONE-HEAD ZONE-RECORD*
7e282fb5 657
2f1d381d
MW
658 ZONE-RECORD:
659 ((NAME*) ZONE-RECORD*)
660 | SYM ARGS"
7e282fb5 661 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
8fcf1ae3
MW
662 (make-zone :name zname
663 :default-ttl ttl
664 :soa soa
665 :records (zone-parse-records zname ttl (cdr zf)))))
7e282fb5 666
afa2e2f1 667(export 'zone-create)
fe5fb85a 668(defun zone-create (zf)
db43369d
MW
669 "Zone construction function.
670
671 Given a zone form ZF, construct the zone and add it to the table."
fe5fb85a 672 (let* ((zone (zone-parse zf))
db43369d 673 (name (zone-text-name zone)))
fe5fb85a
MW
674 (setf (zone-find name) zone)
675 name))
676
afa2e2f1 677(export 'defzone)
32ebbe9b 678(defmacro defzone (soa &body zf)
fe5fb85a
MW
679 "Zone definition macro."
680 `(zone-create '(,soa ,@zf)))
681
32ebbe9b
MW
682(export '*address-family*)
683(defvar *address-family* t
684 "The default address family. This is bound by `defrevzone'.")
685
afa2e2f1 686(export 'defrevzone)
32ebbe9b 687(defmacro defrevzone (head &body zf)
fe5fb85a 688 "Define a reverse zone, with the correct name."
32ebbe9b
MW
689 (destructuring-bind (nets &rest args
690 &key &allow-other-keys
691 (family '*address-family*)
692 prefix-bits)
fe5fb85a 693 (listify head)
32ebbe9b
MW
694 (with-gensyms (ipn)
695 `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
696 (let ((*address-family* (ipnet-family ,ipn)))
71739167
MW
697 (zone-create `((,(format nil "~A" (reverse-domain ,ipn
698 ,prefix-bits))
32ebbe9b
MW
699 ,@',(loop for (k v) on args by #'cddr
700 unless (member k
701 '(:family :prefix-bits))
702 nconc (list k v)))
703 ,@',zf)))))))
704
7c34d08c 705(export 'map-host-addresses)
32ebbe9b
MW
706(defun map-host-addresses (func addr &key (family *address-family*))
707 "Call FUNC for each address denoted by ADDR (a `host-parse' address)."
708
709 (dolist (a (host-addrs (host-parse addr family)))
710 (funcall func a)))
711
7c34d08c 712(export 'do-host)
32ebbe9b
MW
713(defmacro do-host ((addr spec &key (family *address-family*)) &body body)
714 "Evaluate BODY, binding ADDR to each address denoted by SPEC."
715 `(dolist (,addr (host-addrs (host-parse ,spec ,family)))
716 ,@body))
717
718(export 'zone-set-address)
719(defun zone-set-address (rec addrspec &rest args
720 &key (family *address-family*) name ttl make-ptr-p)
721 "Write records (using REC) defining addresses for ADDRSPEC."
722 (declare (ignore name ttl make-ptr-p))
723 (let ((key-args (loop for (k v) on args by #'cddr
724 unless (eq k :family)
725 nconc (list k v))))
726 (do-host (addr addrspec :family family)
727 (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))
fe5fb85a
MW
728
729;;;--------------------------------------------------------------------------
9f408c60
MW
730;;; Building raw record vectors.
731
732(defvar *record-vector* nil
733 "The record vector under construction.")
734
735(defun rec-ensure (n)
736 "Ensure that at least N octets are spare in the current record."
737 (let ((want (+ n (fill-pointer *record-vector*)))
738 (have (array-dimension *record-vector* 0)))
739 (unless (<= want have)
740 (adjust-array *record-vector*
741 (do ((new (* 2 have) (* 2 new)))
742 ((<= want new) new))))))
743
2c446779
MW
744(export 'rec-octet-vector)
745(defun rec-octet-vector (vector &key (start 0) end)
746 "Copy (part of) the VECTOR to the output."
747 (let* ((end (or end (length vector)))
748 (len (- end start)))
749 (rec-ensure len)
750 (do ((i start (1+ i)))
751 ((>= i end))
752 (vector-push (aref vector i) *record-vector*))))
753
9f408c60
MW
754(export 'rec-byte)
755(defun rec-byte (octets value)
756 "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record."
757 (rec-ensure octets)
758 (do ((i (1- octets) (1- i)))
759 ((minusp i))
760 (vector-push (ldb (byte 8 (* 8 i)) value) *record-vector*)))
761
762(export 'rec-u8)
763(defun rec-u8 (value)
764 "Append an 8-bit VALUE to the current record."
765 (rec-byte 1 value))
766
767(export 'rec-u16)
768(defun rec-u16 (value)
769 "Append a 16-bit VALUE to the current record."
770 (rec-byte 2 value))
771
772(export 'rec-u32)
773(defun rec-u32 (value)
774 "Append a 32-bit VALUE to the current record."
775 (rec-byte 4 value))
776
777(export 'rec-raw-string)
778(defun rec-raw-string (s &key (start 0) end)
779 "Append (a (substring of) a raw string S to the current record.
780
781 No arrangement is made for reporting the length of the string. That must
782 be done by the caller, if necessary."
783 (setf-default end (length s))
784 (rec-ensure (- end start))
785 (do ((i start (1+ i)))
786 ((>= i end))
787 (vector-push (char-code (char s i)) *record-vector*)))
788
789(export 'rec-string)
790(defun rec-string (s &key (start 0) end (max 255))
791 (let* ((end (or end (length s)))
792 (len (- end start)))
793 (unless (<= len max)
794 (error "String `~A' too long" (subseq s start end)))
795 (rec-u8 (- end start))
796 (rec-raw-string s :start start :end end)))
797
798(export 'rec-name)
db43369d
MW
799(defun rec-name (name)
800 "Append a domain NAME.
9f408c60
MW
801
802 No attempt is made to perform compression of the name."
db43369d
MW
803 (dolist (label (reverse (domain-name-labels name)))
804 (rec-string label :max 63))
805 (rec-u8 0))
9f408c60
MW
806
807(export 'build-record)
808(defmacro build-record (&body body)
809 "Build a raw record, and return it as a vector of octets."
810 `(let ((*record-vector* (make-array 256
811 :element-type '(unsigned-byte 8)
812 :fill-pointer 0
813 :adjustable t)))
814 ,@body
815 (copy-seq *record-vector*)))
816
817(export 'zone-record-rrdata)
818(defgeneric zone-record-rrdata (type zr)
819 (:documentation "Emit (using the `build-record' protocol) RRDATA for ZR.
820
821 The TYPE is a keyword naming the record type. Return the numeric RRTYPE
822 code."))
823
824;;;--------------------------------------------------------------------------
fe5fb85a
MW
825;;; Zone record parsers.
826
4e7e3780 827(defzoneparse :a (name data rec)
7e282fb5 828 ":a IPADDR"
32ebbe9b
MW
829 (zone-set-address #'rec data :make-ptr-p t :family :ipv4))
830
9f408c60
MW
831(defmethod zone-record-rrdata ((type (eql :a)) zr)
832 (rec-u32 (ipaddr-addr (zr-data zr)))
833 1)
834
a2267e14
MW
835(defzoneparse :aaaa (name data rec)
836 ":aaaa IPADDR"
837 (zone-set-address #'rec data :make-ptr-p t :family :ipv6))
838
9f408c60
MW
839(defmethod zone-record-rrdata ((type (eql :aaaa)) zr)
840 (rec-byte 16 (ipaddr-addr (zr-data zr)))
841 28)
842
32ebbe9b
MW
843(defzoneparse :addr (name data rec)
844 ":addr IPADDR"
845 (zone-set-address #'rec data :make-ptr-p t))
590ad961
MW
846
847(defzoneparse :svc (name data rec)
848 ":svc IPADDR"
32ebbe9b 849 (zone-set-address #'rec data))
fe5fb85a 850
7e282fb5 851(defzoneparse :ptr (name data rec :zname zname)
852 ":ptr HOST"
853 (rec :data (zone-parse-host data zname)))
fe5fb85a 854
9f408c60
MW
855(defmethod zone-record-rrdata ((type (eql :ptr)) zr)
856 (rec-name (zr-data zr))
857 12)
858
7e282fb5 859(defzoneparse :cname (name data rec :zname zname)
860 ":cname HOST"
861 (rec :data (zone-parse-host data zname)))
fe5fb85a 862
9f408c60
MW
863(defmethod zone-record-rrdata ((type (eql :cname)) zr)
864 (rec-name (zr-data zr))
865 5)
866
90022a23 867(defzoneparse :txt (name data rec)
4ea82aba
MW
868 ":txt (TEXT*)"
869 (rec :data (listify data)))
90022a23 870
9f408c60
MW
871(defmethod zone-record-rrdata ((type (eql :txt)) zr)
872 (mapc #'rec-string (zr-data zr))
873 16)
874
f760c73a
MW
875(export '*dkim-pathname-defaults*)
876(defvar *dkim-pathname-defaults*
877 (make-pathname :directory '(:relative "keys")
878 :type "dkim"))
2d8313b9 879(pushnew '*dkim-pathname-defaults* *zone-config*)
f760c73a 880
75f39e1a
MW
881(defzoneparse :dkim (name data rec)
882 ":dkim (KEYFILE {:TAG VALUE}*)"
883 (destructuring-bind (file &rest plist) (listify data)
884 (let ((things nil) (out nil))
885 (labels ((flush ()
886 (when out
887 (push (get-output-stream-string out) things)
888 (setf out nil)))
889 (emit (text)
890 (let ((len (length text)))
891 (when (and out (> (+ (file-position out)
892 (length text))
893 64))
894 (flush))
895 (when (plusp len)
896 (cond ((< len 64)
bd54e509
MW
897 (unless out
898 (setf out (make-string-output-stream)))
75f39e1a
MW
899 (write-string text out))
900 (t
901 (do ((i 0 j)
902 (j 64 (+ j 64)))
903 ((>= i len))
bd54e509
MW
904 (push (subseq text i (min j len))
905 things))))))))
75f39e1a
MW
906 (do ((p plist (cddr p)))
907 ((endp p))
908 (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
909 (emit (with-output-to-string (out)
910 (write-string "p=" out)
911 (when file
f760c73a
MW
912 (with-open-file
913 (in (merge-pathnames file *dkim-pathname-defaults*))
75f39e1a
MW
914 (loop
915 (when (string= (read-line in)
916 "-----BEGIN PUBLIC KEY-----")
917 (return)))
918 (loop
919 (let ((line (read-line in)))
920 (if (string= line "-----END PUBLIC KEY-----")
921 (return)
922 (write-string line out)))))))))
923 (rec :type :txt
924 :data (nreverse things)))))
925
c0d02a95 926(defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3) (:ed25519 4))
cab61922 927(defenum sshfp-type () (:sha-1 1) (:sha-256 2))
f1d7d492 928
f760c73a
MW
929(export '*sshfp-pathname-defaults*)
930(defvar *sshfp-pathname-defaults*
2d8313b9
MW
931 (make-pathname :directory '(:relative "keys") :type "sshfp")
932 "Default pathname components for SSHFP records.")
933(pushnew '*sshfp-pathname-defaults* *zone-config*)
f760c73a 934
f1d7d492
MW
935(defzoneparse :sshfp (name data rec)
936 ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
62e6acc9
MW
937 (typecase data
938 ((or string pathname)
939 (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
940 (loop (let ((line (read-line in nil)))
941 (unless line (return))
942 (let ((words (str-split-words line)))
943 (pop words)
944 (when (string= (car words) "IN") (pop words))
945 (unless (and (string= (car words) "SSHFP")
946 (= (length words) 4))
947 (error "Invalid SSHFP record."))
948 (pop words)
949 (destructuring-bind (alg type fpr) words
950 (rec :data (list (parse-integer alg)
951 (parse-integer type)
952 fpr))))))))
953 (t
954 (dolist (item (listify data))
955 (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
956 (listify item)
957 (rec :data (list (lookup-enum alg 'sshfp-algorithm :min 0 :max 255)
958 (lookup-enum type 'sshfp-type :min 0 :max 255)
959 fpr)))))))
f1d7d492 960
9f408c60
MW
961(defmethod zone-record-rrdata ((type (eql :sshfp)) zr)
962 (destructuring-bind (alg type fpr) (zr-data zr)
963 (rec-u8 alg)
964 (rec-u8 type)
965 (do ((i 0 (+ i 2))
966 (n (length fpr)))
967 ((>= i n))
968 (rec-u8 (parse-integer fpr :start i :end (+ i 2) :radix 16))))
969 44)
970
29d9eca4
MW
971(defenum tlsa-usage ()
972 (:ca-constraint 0)
973 (:service-certificate-constraint 1)
974 (:trust-anchor-assertion 2)
975 (:domain-issued-certificate 3))
976
977(defenum tlsa-selector ()
978 (:certificate 0)
979 (:public-key 1))
980
981(defenum tlsa-match ()
982 (:exact 0)
983 (:sha-256 1)
984 (:sha-512 2))
985
986(defparameter tlsa-pem-alist
987 `(("CERTIFICATE" . ,tlsa-selector/certificate)
988 ("PUBLIC-KEY" . ,tlsa-selector/public-key)))
989
990(defgeneric raw-tlsa-assoc-data (have want file context)
991 (:documentation
992 "Convert FILE, and strip off PEM encoding.
993
994 The FILE contains PEM-encoded data of type HAVE -- one of the
995 `tlsa-selector' codes. Return the name of a file containing binary
996 DER-encoded data of type WANT instead. The CONTEXT is a temporary-files
997 context.")
998
999 (:method (have want file context)
1000 (declare (ignore context))
1001 (error "Can't convert `~A' from selector type ~S to type ~S" file
1002 (reverse-enum 'tlsa-selector have)
1003 (reverse-enum 'tlsa-selector want)))
1004
1005 (:method ((have (eql tlsa-selector/certificate))
1006 (want (eql tlsa-selector/certificate))
1007 file context)
1008 (let ((temp (temporary-file context "cert")))
1009 (run-program (list "openssl" "x509" "-outform" "der")
1010 :input file :output temp)
1011 temp))
1012
1013 (:method ((have (eql tlsa-selector/public-key))
1014 (want (eql tlsa-selector/public-key))
1015 file context)
1016 (let ((temp (temporary-file context "pubkey-der")))
1017 (run-program (list "openssl" "pkey" "-pubin" "-outform" "der")
1018 :input file :output temp)
1019 temp))
1020
1021 (:method ((have (eql tlsa-selector/certificate))
1022 (want (eql tlsa-selector/public-key))
1023 file context)
1024 (let ((temp (temporary-file context "pubkey")))
1025 (run-program (list "openssl" "x509" "-noout" "-pubkey")
1026 :input file :output temp)
1027 (raw-tlsa-assoc-data want want temp context))))
1028
1029(defgeneric tlsa-match-data-valid-p (match data)
1030 (:documentation
1031 "Check whether the DATA (an octet vector) is valid for the MATCH type.")
1032
1033 (:method (match data)
1034 (declare (ignore match data))
1035 ;; We don't know: assume the user knows what they're doing.
1036 t)
1037
1038 (:method ((match (eql tlsa-match/sha-256)) data) (= (length data) 32))
1039 (:method ((match (eql tlsa-match/sha-512)) data) (= (length data) 64)))
1040
1041(defgeneric read-tlsa-match-data (match file context)
1042 (:documentation
1043 "Read FILE, and return an octet vector for the correct MATCH type.
1044
1045 CONTEXT is a temporary-files context.")
1046 (:method ((match (eql tlsa-match/exact)) file context)
1047 (declare (ignore context))
1048 (slurp-file file 'octet))
1049 (:method ((match (eql tlsa-match/sha-256)) file context)
1050 (hash-file "sha256" file context))
1051 (:method ((match (eql tlsa-match/sha-512)) file context)
1052 (hash-file "sha512" file context)))
1053
1054(defgeneric tlsa-selector-pem-boundary (selector)
1055 (:documentation
1056 "Return the PEM boundary string for objects of the SELECTOR type")
1057 (:method ((selector (eql tlsa-selector/certificate))) "CERTIFICATE")
1058 (:method ((selector (eql tlsa-selector/public-key))) "PUBLIC KEY")
1059 (:method (selector) (declare (ignore selector)) nil))
1060
1061(defun identify-tlsa-selector-file (file)
1062 "Return the selector type for the data stored in a PEM-format FILE."
1063 (with-open-file (in file)
1064 (loop
1065 (let* ((line (read-line in nil))
1066 (len (length line)))
1067 (unless line
1068 (error "No PEM boundary in `~A'" file))
1069 (when (and (>= len 11)
1070 (string= line "-----BEGIN " :end1 11)
1071 (string= line "-----" :start1 (- len 5)))
1072 (mapenum (lambda (tag value)
1073 (declare (ignore tag))
1074 (when (string= line
1075 (tlsa-selector-pem-boundary value)
1076 :start1 11 :end1 (- len 5))
1077 (return value)))
1078 'tlsa-selector))))))
1079
729a79bd
MW
1080(export '*tlsa-pathname-defaults*)
1081(defvar *tlsa-pathname-defaults*
1082 (list (make-pathname :directory '(:relative "certs") :type "cert")
1083 (make-pathname :directory '(:relative "keys") :type "pub"))
1084 "Default pathname components for TLSA records.")
1085(pushnew '*tlsa-pathname-defaults* *zone-config*)
1086
321d7160
MW
1087(defparameter *tlsa-data-cache* (make-hash-table :test #'equal)
1088 "Cache for TLSA association data; keys are (DATA SELECTOR MATCH).")
1089
29d9eca4
MW
1090(defun convert-tlsa-selector-data (data selector match)
1091 "Convert certificate association DATA as required by SELECTOR and MATCH.
1092
1093 If DATA is a hex string, we assume that it's already in the appropriate
1094 form (but if MATCH specifies a hash then we check that it's the right
1095 length). If DATA is a pathname, then it should name a PEM file: we
1096 identify the kind of object stored in the file from the PEM header, and
1097 convert as necessary.
1098
1099 The output is an octet vector containing the raw certificate association
1100 data to include in rrdata."
1101
1102 (etypecase data
1103 (string
1104 (let ((bin (decode-hex data)))
1105 (unless (tlsa-match-data-valid-p match bin)
1106 (error "Invalid data for match type ~S"
1107 (reverse-enum 'tlsa-match match)))
1108 bin))
1109 (pathname
321d7160
MW
1110 (let ((key (list data selector match)))
1111 (or (gethash key *tlsa-data-cache*)
1112 (with-temporary-files (context :base (make-pathname :type "tmp"))
1113 (let* ((file (or (find-if #'probe-file
1114 (mapcar (lambda (template)
1115 (merge-pathnames data
1116 template))
1117 *tlsa-pathname-defaults*))
1118 (error "Couldn't find TLSA file `~A'" data)))
1119 (kind (identify-tlsa-selector-file file))
1120 (raw (raw-tlsa-assoc-data kind selector file context))
1121 (binary (read-tlsa-match-data match raw context)))
1122 (setf (gethash key *tlsa-data-cache*) binary))))))))
29d9eca4
MW
1123
1124(defzoneparse :tlsa (name data rec)
1125 ":tlsa (((SERVICE|PORT &key :protocol)*) (USAGE SELECTOR MATCH DATA)*)"
1126
1127 (destructuring-bind (services &rest certinfos) data
1128
1129 ;; First pass: build the raw-format TLSA record data.
1130 (let ((records nil))
1131 (dolist (certinfo certinfos)
1132 (destructuring-bind (usage-tag selector-tag match-tag data) certinfo
1133 (let* ((usage (lookup-enum 'tlsa-usage usage-tag :min 0 :max 255))
1134 (selector (lookup-enum 'tlsa-selector selector-tag
1135 :min 0 :max 255))
1136 (match (lookup-enum 'tlsa-match match-tag :min 0 :max 255))
1137 (raw (convert-tlsa-selector-data data selector match)))
1138 (push (list usage selector match raw) records))))
1139 (setf records (nreverse records))
1140
1141 ;; Second pass: attach records for the requested services.
1142 (dolist (service (listify services))
1143 (destructuring-bind (svc &key (protocol :tcp)) (listify service)
1144 (let* ((port (etypecase svc
1145 (integer svc)
1146 (keyword (let ((serv (serv-by-name svc protocol)))
1147 (unless serv
1148 (error "Unknown service `~A'" svc))
1149 (serv-port serv)))))
1150 (prefixed (domain-name-concat
1151 (make-domain-name
1152 :labels (list (format nil "_~(~A~)" protocol)
1153 (format nil "_~A" port)))
1154 name)))
1155 (dolist (record records)
1156 (rec :name prefixed :data record))))))))
1157
1158(defmethod zone-record-rrdata ((type (eql :tlsa)) zr)
1159 (destructuring-bind (usage selector match data) (zr-data zr)
1160 (rec-u8 usage)
1161 (rec-u8 selector)
1162 (rec-u8 match)
1163 (rec-octet-vector data))
1164 52)
1165
7f00d93d
MW
1166(defenum dnssec-algorithm ()
1167 (:rsamd5 1)
1168 (:dh 2)
1169 (:dsa 3)
1170 (:rsasha1 5)
1171 (:dsa-nsec3-sha1 6)
1172 (:rsasha1-nsec3-sha1 7)
1173 (:rsasha256 8)
1174 (:rsasha512 10)
1175 (:ecc-gost 12)
1176 (:ecdsap256sha256 13)
1177 (:ecdsap384sha384 14))
1178
1179(defenum dnssec-digest ()
1180 (:sha1 1)
1181 (:sha256 2))
1182
1183(defzoneparse :ds (name data rec)
1184 ":ds ((TAG ALGORITHM DIGEST-TYPE DIGEST)*)"
1185 (dolist (ds data)
1186 (destructuring-bind (tag alg hashtype hash) ds
1187 (rec :data (list tag
1188 (lookup-enum 'dnssec-algorithm alg :min 0 :max 255)
1189 (lookup-enum 'dnssec-digest hashtype :min 0 :max 255)
1190 (decode-hex hash))))))
1191
1192(defmethod zone-record-rrdata ((type (eql :ds)) zr)
1193 (destructuring-bind (tag alg hashtype hash) zr
1194 (rec-u16 tag)
1195 (rec-u8 alg)
1196 (rec-u8 hashtype)
1197 (rec-octet-vector hash)))
1198
7e282fb5 1199(defzoneparse :mx (name data rec :zname zname)
1200 ":mx ((HOST :prio INT :ip IPADDR)*)"
1201 (dolist (mx (listify data))
1202 (destructuring-bind
1203 (mxname &key (prio *default-mx-priority*) ip)
1204 (listify mx)
1205 (let ((host (zone-parse-host mxname zname)))
32ebbe9b 1206 (when ip (zone-set-address #'rec ip :name host))
7e282fb5 1207 (rec :data (cons host prio))))))
fe5fb85a 1208
9f408c60
MW
1209(defmethod zone-record-rrdata ((type (eql :mx)) zr)
1210 (let ((name (car (zr-data zr)))
1211 (prio (cdr (zr-data zr))))
1212 (rec-u16 prio)
1213 (rec-name name))
1214 15)
1215
7e282fb5 1216(defzoneparse :ns (name data rec :zname zname)
1217 ":ns ((HOST :ip IPADDR)*)"
1218 (dolist (ns (listify data))
1219 (destructuring-bind
1220 (nsname &key ip)
1221 (listify ns)
1222 (let ((host (zone-parse-host nsname zname)))
32ebbe9b 1223 (when ip (zone-set-address #'rec ip :name host))
7e282fb5 1224 (rec :data host)))))
fe5fb85a 1225
9f408c60
MW
1226(defmethod zone-record-rrdata ((type (eql :ns)) zr)
1227 (rec-name (zr-data zr))
1228 2)
1229
7e282fb5 1230(defzoneparse :alias (name data rec :zname zname)
1231 ":alias (LABEL*)"
1232 (dolist (a (listify data))
1233 (rec :name (zone-parse-host a zname)
1234 :type :cname
1235 :data name)))
fe5fb85a 1236
716105aa 1237(defzoneparse :srv (name data rec :zname zname)
1b5ebe0a
MW
1238 ":srv (((SERVICE &key :port :protocol)
1239 (PROVIDER &key :port :prio :weight :ip)*)*)"
716105aa
MW
1240 (dolist (srv data)
1241 (destructuring-bind (servopts &rest providers) srv
1242 (destructuring-bind
1243 (service &key ((:port default-port)) (protocol :tcp))
1244 (listify servopts)
1245 (unless default-port
1246 (let ((serv (serv-by-name service protocol)))
1247 (setf default-port (and serv (serv-port serv)))))
db43369d
MW
1248 (let ((rname (flet ((prepend (tag tail)
1249 (domain-name-concat
1250 (make-domain-name
1251 :labels (list (format nil "_~(~A~)" tag)))
1252 tail)))
1253 (prepend service (prepend protocol name)))))
716105aa
MW
1254 (dolist (prov providers)
1255 (destructuring-bind
1256 (srvname
1257 &key
1258 (port default-port)
1259 (prio *default-mx-priority*)
1260 (weight 0)
1261 ip)
1262 (listify prov)
1263 (let ((host (zone-parse-host srvname zname)))
32ebbe9b 1264 (when ip (zone-set-address #'rec ip :name host))
716105aa
MW
1265 (rec :name rname
1266 :data (list prio weight port host))))))))))
1267
9f408c60
MW
1268(defmethod zone-record-rrdata ((type (eql :srv)) zr)
1269 (destructuring-bind (prio weight port host) (zr-data zr)
1270 (rec-u16 prio)
1271 (rec-u16 weight)
1272 (rec-u16 port)
1273 (rec-name host))
1274 33)
1275
a15288b4 1276(defzoneparse :net (name data rec)
1277 ":net (NETWORK*)"
1278 (dolist (net (listify data))
32ebbe9b
MW
1279 (dolist (ipn (net-ipnets (net-must-find net)))
1280 (let* ((base (ipnet-net ipn))
1281 (rrtype (ipaddr-rrtype base)))
1282 (flet ((frob (kind addr)
1283 (when addr
1284 (rec :name (zone-parse-host kind name)
1285 :type rrtype
1286 :data addr))))
1287 (frob "net" base)
1288 (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn)))
1289 (frob "bcast" (ipnet-broadcast ipn)))))))
7fff3797 1290
7e282fb5 1291(defzoneparse (:rev :reverse) (name data rec)
32ebbe9b 1292 ":reverse ((NET &key :prefix-bits :family) ZONE*)
679775ba
MW
1293
1294 Add a reverse record each host in the ZONEs (or all zones) that lies
32ebbe9b 1295 within NET."
7e282fb5 1296 (setf data (listify data))
32ebbe9b
MW
1297 (destructuring-bind (net &key prefix-bits (family *address-family*))
1298 (listify (car data))
1299
1300 (dolist (ipn (net-parse-to-ipnets net family))
1301 (let* ((seen (make-hash-table :test #'equal))
1302 (width (ipnet-width ipn))
1303 (frag-len (if prefix-bits (- width prefix-bits)
1304 (ipnet-changeable-bits width (ipnet-mask ipn)))))
1305 (dolist (z (or (cdr data) (hash-table-keys *zones*)))
1306 (dolist (zr (zone-records (zone-find z)))
1307 (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn)))
1308 (zr-make-ptr-p zr)
1309 (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
1310 (let* ((frag (reverse-domain-fragment (zr-data zr)
1311 0 frag-len))
db43369d
MW
1312 (name (domain-name-concat frag name))
1313 (name-string (princ-to-string name)))
1314 (unless (gethash name-string seen)
32ebbe9b
MW
1315 (rec :name name :type :ptr
1316 :ttl (zr-ttl zr) :data (zr-name zr))
db43369d 1317 (setf (gethash name-string seen) t))))))))))
32ebbe9b 1318
74962377 1319(defzoneparse :multi (name data rec :zname zname :ttl ttl)
32ebbe9b
MW
1320 ":multi (((NET*) &key :start :end :family :suffix) . REC)
1321
1322 Output multiple records covering a portion of the reverse-resolution
1323 namespace corresponding to the particular NETs. The START and END bounds
1324 default to the most significant variable component of the
1325 reverse-resolution domain.
1326
1327 The REC tail is a sequence of record forms (as handled by
1328 `zone-process-records') to be emitted for each covered address. Within
1329 the bodies of these forms, the symbol `*' will be replaced by the
1330 domain-name fragment corresponding to the current host, optionally
1331 followed by the SUFFIX.
1332
1333 Examples:
1334
1335 (:multi ((delegated-subnet :start 8)
1336 :ns (some.ns.delegated.example :ip \"169.254.5.2\")))
1337
1338 (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\")
1339 :cname *))
1340
1341 Obviously, nested `:multi' records won't work well."
1342
db43369d
MW
1343 (destructuring-bind (nets
1344 &key start end ((:suffix raw-suffix))
1345 (family *address-family*))
32ebbe9b 1346 (listify (car data))
db43369d
MW
1347 (let ((suffix (if (not raw-suffix)
1348 (make-domain-name :labels nil :absolutep nil)
1349 (zone-parse-host raw-suffix))))
1350 (dolist (net (listify nets))
1351 (dolist (ipn (net-parse-to-ipnets net family))
1352 (let* ((addr (ipnet-net ipn))
1353 (width (ipaddr-width addr))
1354 (comp-width (reverse-domain-component-width addr))
1355 (end (round-up (or end
1356 (ipnet-changeable-bits width
1357 (ipnet-mask ipn)))
1358 comp-width))
1359 (start (round-down (or start (- end comp-width))
1360 comp-width))
1361 (map (ipnet-host-map ipn)))
1362 (multiple-value-bind (host-step host-limit)
1363 (ipnet-index-bounds map start end)
1364 (do ((index 0 (+ index host-step)))
1365 ((> index host-limit))
1366 (let* ((addr (ipnet-index-host map index))
1367 (frag (reverse-domain-fragment addr start end))
1368 (target (reduce #'domain-name-concat
1369 (list frag suffix zname)
1370 :from-end t
1371 :initial-value root-domain)))
1372 (dolist (zr (zone-parse-records (domain-name-concat frag
1373 zname)
1374 ttl
1375 (subst target '*
1376 (cdr data))))
1377 (rec :name (zr-name zr)
1378 :type (zr-type zr)
1379 :data (zr-data zr)
1380 :ttl (zr-ttl zr)
1381 :make-ptr-p (zr-make-ptr-p zr))))))))))))
7e282fb5 1382
fe5fb85a
MW
1383;;;--------------------------------------------------------------------------
1384;;; Zone file output.
7e282fb5 1385
afa2e2f1 1386(export 'zone-write)
a567a3bc
MW
1387(defgeneric zone-write (format zone stream)
1388 (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
1389
1390(defvar *writing-zone* nil
1391 "The zone currently being written.")
1392
1393(defvar *zone-output-stream* nil
1394 "Stream to write zone data on.")
1395
9f408c60 1396(export 'zone-write-raw-rrdata)
146571da
MW
1397(defgeneric zone-write-raw-rrdata (format zr type data)
1398 (:documentation "Write an otherwise unsupported record in a given FORMAT.
1399
1400 ZR gives the record object, which carries the name and TTL; the TYPE is
1401 the numeric RRTYPE code; and DATA is an octet vector giving the RRDATA.
1402 This is used by the default `zone-write-record' method to handle record
1403 types which aren't directly supported by the format driver."))
1404
1405(export 'zone-write-header)
1406(defgeneric zone-write-header (format zone)
1407 (:documentation "Emit the header for a ZONE, in a given FORMAT.
1408
1409 The header includes any kind of initial comment, the SOA record, and any
1410 other necessary preamble. There is no default implementation.
1411
1412 This is part of the protocol used by the default method on `zone-write';
1413 if you override that method."))
1414
1415(export 'zone-write-trailer)
1416(defgeneric zone-write-trailer (format zone)
1417 (:documentation "Emit the header for a ZONE, in a given FORMAT.
1418
1419 The footer may be empty, and is so by default.
1420
1421 This is part of the protocol used by the default method on `zone-write';
1422 if you override that method.")
1423 (:method (format zone)
1424 (declare (ignore format zone))
1425 nil))
1426
1427(export 'zone-write-record)
1428(defgeneric zone-write-record (format type zr)
1429 (:documentation "Emit a record of the given TYPE (a keyword).
1430
9f408c60
MW
1431 The default implementation builds the raw RRDATA and passes it to
1432 `zone-write-raw-rrdata'.")
1433 (:method (format type zr)
1434 (let* (code
1435 (data (build-record (setf code (zone-record-rrdata type zr)))))
1436 (zone-write-raw-rrdata format zr code data))))
146571da
MW
1437
1438(defmethod zone-write (format zone stream)
1439 "This default method calls `zone-write-header', then `zone-write-record'
1440 for each record in the zone, and finally `zone-write-trailer'. While it's
1441 running, `*writing-zone*' is bound to the zone object, and
1442 `*zone-output-stream*' to the output stream."
a567a3bc
MW
1443 (let ((*writing-zone* zone)
1444 (*zone-output-stream* stream))
146571da
MW
1445 (zone-write-header format zone)
1446 (dolist (zr (zone-records-sorted zone))
1447 (zone-write-record format (zr-type zr) zr))
1448 (zone-write-trailer format zone)))
a567a3bc 1449
afa2e2f1 1450(export 'zone-save)
a567a3bc
MW
1451(defun zone-save (zones &key (format :bind))
1452 "Write the named ZONES to files. If no zones are given, write all the
1453 zones."
1454 (unless zones
1455 (setf zones (hash-table-keys *zones*)))
1456 (safely (safe)
1457 (dolist (z zones)
1458 (let ((zz (zone-find z)))
1459 (unless zz
1460 (error "Unknown zone `~A'." z))
1461 (let ((stream (safely-open-output-stream safe
1462 (zone-file-name z :zone))))
5bc6b584
MW
1463 (zone-write format zz stream)
1464 (close stream))))))
a567a3bc
MW
1465
1466;;;--------------------------------------------------------------------------
1467;;; Bind format output.
1468
80b5c2ff
MW
1469(defvar *bind-last-record-name* nil
1470 "The previously emitted record name.
1471
1472 Used for eliding record names on output.")
1473
afa2e2f1 1474(export 'bind-hostname)
a567a3bc 1475(defun bind-hostname (hostname)
db43369d
MW
1476 (let ((zone (domain-name-labels (zone-name *writing-zone*)))
1477 (name (domain-name-labels hostname)))
1478 (loop
1479 (unless (and zone name (string= (car zone) (car name)))
1480 (return))
1481 (pop zone) (pop name))
1482 (flet ((stitch (labels absolutep)
1483 (format nil "~{~A~^.~}~@[.~]"
1484 (reverse (mapcar #'quotify-label labels))
1485 absolutep)))
1486 (cond (zone (stitch (domain-name-labels hostname) t))
1487 (name (stitch name nil))
1488 (t "@")))))
80b5c2ff
MW
1489
1490(export 'bind-output-hostname)
1491(defun bind-output-hostname (hostname)
1492 (let ((name (bind-hostname hostname)))
1493 (cond ((and *bind-last-record-name*
1494 (string= name *bind-last-record-name*))
1495 "")
1496 (t
1497 (setf *bind-last-record-name* name)
1498 name))))
a567a3bc 1499
146571da 1500(defmethod zone-write :around ((format (eql :bind)) zone stream)
807e319f 1501 (declare (ignorable zone stream))
146571da
MW
1502 (let ((*bind-last-record-name* nil))
1503 (call-next-method)))
32ebbe9b 1504
146571da
MW
1505(defmethod zone-write-header ((format (eql :bind)) zone)
1506 (format *zone-output-stream* "~
7e282fb5 1507;;; Zone file `~(~A~)'
1508;;; (generated ~A)
1509
7d593efd
MW
1510$ORIGIN ~0@*~(~A.~)
1511$TTL ~2@*~D~2%"
7e282fb5 1512 (zone-name zone)
1513 (iso-date :now :datep t :timep t)
1514 (zone-default-ttl zone))
146571da 1515 (let* ((soa (zone-soa zone))
a567a3bc
MW
1516 (admin (let* ((name (soa-admin soa))
1517 (at (position #\@ name))
1518 (copy (format nil "~(~A~)." name)))
1519 (when at
1520 (setf (char copy at) #\.))
1521 copy)))
146571da 1522 (format *zone-output-stream* "~
fffebf35
MW
1523~A~30TIN SOA~40T~A (
1524~55@A~60T ;administrator
7e282fb5 1525~45T~10D~60T ;serial
1526~45T~10D~60T ;refresh
1527~45T~10D~60T ;retry
1528~45T~10D~60T ;expire
1529~45T~10D )~60T ;min-ttl~2%"
80b5c2ff 1530 (bind-output-hostname (zone-name zone))
a567a3bc
MW
1531 (bind-hostname (soa-source soa))
1532 admin
7e282fb5 1533 (soa-serial soa)
1534 (soa-refresh soa)
1535 (soa-retry soa)
1536 (soa-expire soa)
146571da 1537 (soa-min-ttl soa))))
a567a3bc 1538
afa2e2f1 1539(export 'bind-format-record)
146571da 1540(defun bind-format-record (zr format &rest args)
a567a3bc 1541 (format *zone-output-stream*
05162113 1542 "~A~20T~@[~8D~]~30TIN ~A~40T~?"
146571da
MW
1543 (bind-output-hostname (zr-name zr))
1544 (let ((ttl (zr-ttl zr)))
1545 (and (/= ttl (zone-default-ttl *writing-zone*))
1546 ttl))
1547 (string-upcase (symbol-name (zr-type zr)))
a567a3bc
MW
1548 format args))
1549
5b67c26c
MW
1550(export 'bind-write-hex)
1551(defun bind-write-hex (vector remain)
1552 "Output the VECTOR as hex, in Bind format.
1553
1554 If the length (in bytes) is less than REMAIN then it's placed on the
1555 current line; otherwise the Bind line-continuation syntax is used."
1556 (flet ((output-octet (octet)
1557 (format *zone-output-stream* "~(~2,'0X~)" octet)))
1558 (let ((len (length vector)))
1559 (cond ((< len remain)
1560 (dotimes (i len) (output-octet (aref vector i)))
1561 (terpri *zone-output-stream*))
1562 (t
1563 (format *zone-output-stream* "(")
1564 (let ((i 0))
1565 (loop
1566 (when (>= i len) (return))
1567 (let ((limit (min len (+ i 64))))
1568 (format *zone-output-stream* "~%~8T")
1569 (loop
1570 (when (>= i limit) (return))
1571 (output-octet (aref vector i))
1572 (incf i)))))
1573 (format *zone-output-stream* " )~%"))))))
1574
9f408c60
MW
1575(defmethod zone-write-raw-rrdata ((format (eql :bind)) zr type data)
1576 (format *zone-output-stream*
5b67c26c 1577 "~A~20T~@[~8D~]~30TIN TYPE~A~40T\\# ~A "
9f408c60
MW
1578 (bind-output-hostname (zr-name zr))
1579 (let ((ttl (zr-ttl zr)))
1580 (and (/= ttl (zone-default-ttl *writing-zone*))
1581 ttl))
1582 type
1583 (length data))
5b67c26c 1584 (bind-write-hex data 12))
9f408c60 1585
146571da 1586(defmethod zone-write-record ((format (eql :bind)) (type (eql :a)) zr)
05162113 1587 (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr))))
146571da
MW
1588
1589(defmethod zone-write-record ((format (eql :bind)) (type (eql :aaaa)) zr)
05162113 1590 (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr))))
146571da
MW
1591
1592(defmethod zone-write-record ((format (eql :bind)) (type (eql :ptr)) zr)
05162113 1593 (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
146571da
MW
1594
1595(defmethod zone-write-record ((format (eql :bind)) (type (eql :cname)) zr)
05162113 1596 (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
146571da
MW
1597
1598(defmethod zone-write-record ((format (eql :bind)) (type (eql :ns)) zr)
05162113 1599 (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
146571da
MW
1600
1601(defmethod zone-write-record ((format (eql :bind)) (type (eql :mx)) zr)
05162113 1602 (bind-format-record zr "~2D ~A~%"
146571da
MW
1603 (cdr (zr-data zr))
1604 (bind-hostname (car (zr-data zr)))))
1605
1606(defmethod zone-write-record ((format (eql :bind)) (type (eql :srv)) zr)
1607 (destructuring-bind (prio weight port host) (zr-data zr)
05162113 1608 (bind-format-record zr "~2D ~5D ~5D ~A~%"
146571da
MW
1609 prio weight port (bind-hostname host))))
1610
1611(defmethod zone-write-record ((format (eql :bind)) (type (eql :sshfp)) zr)
05162113 1612 (bind-format-record zr "~{~2D ~2D ~A~}~%" (zr-data zr)))
146571da 1613
29d9eca4
MW
1614(defmethod zone-write-record ((format (eql :bind)) (type (eql :tlsa)) zr)
1615 (destructuring-bind (usage selector match data) (zr-data zr)
1616 (bind-format-record zr "~2D ~2D ~2D " usage selector match)
1617 (bind-write-hex data 12)))
1618
7f00d93d
MW
1619(defmethod zone-write-record ((format (eql :bind)) (type (eql :ds)) zr)
1620 (destructuring-bind (tag alg hashtype hash) (zr-data zr)
1621 (bind-format-record zr "~5D ~2D ~2D " tag alg hashtype)
1622 (bind-write-hex hash 12)))
1623
146571da 1624(defmethod zone-write-record ((format (eql :bind)) (type (eql :txt)) zr)
05162113
MW
1625 (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}~%"
1626 (zr-data zr)))
32ebbe9b 1627
e97012de
MW
1628;;;--------------------------------------------------------------------------
1629;;; tinydns-data output format.
1630
422e7cfc 1631(export 'tinydns-output)
e97012de
MW
1632(defun tinydns-output (code &rest fields)
1633 (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields))
1634
9f408c60 1635(defmethod zone-write-raw-rrdata ((format (eql :tinydns)) zr type data)
e97012de
MW
1636 (tinydns-output #\: (zr-name zr) type
1637 (with-output-to-string (out)
1638 (dotimes (i (length data))
1639 (let ((byte (aref data i)))
1640 (if (or (<= byte 32)
3986e085 1641 (>= byte 127)
e97012de
MW
1642 (member byte '(#\: #\\) :key #'char-code))
1643 (format out "\\~3,'0O" byte)
1644 (write-char (code-char byte) out)))))
1645 (zr-ttl zr)))
1646
146571da
MW
1647(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :a)) zr)
1648 (tinydns-output #\+ (zr-name zr)
1649 (ipaddr-string (zr-data zr)) (zr-ttl zr)))
1650
1651(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :aaaa)) zr)
1652 (tinydns-output #\3 (zr-name zr)
1653 (format nil "~(~32,'0X~)" (ipaddr-addr (zr-data zr)))
1654 (zr-ttl zr)))
1655
1656(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ptr)) zr)
1657 (tinydns-output #\^ (zr-name zr) (zr-data zr) (zr-ttl zr)))
1658
1659(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :cname)) zr)
1660 (tinydns-output #\C (zr-name zr) (zr-data zr) (zr-ttl zr)))
1661
1662(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ns)) zr)
1663 (tinydns-output #\& (zr-name zr) nil (zr-data zr) (zr-ttl zr)))
1664
1665(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :mx)) zr)
1666 (let ((name (car (zr-data zr)))
1667 (prio (cdr (zr-data zr))))
1668 (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr))))
1669
146571da
MW
1670(defmethod zone-write-header ((format (eql :tinydns)) zone)
1671 (format *zone-output-stream* "~
e97012de
MW
1672### Zone file `~(~A~)'
1673### (generated ~A)
1674~%"
1675 (zone-name zone)
1676 (iso-date :now :datep t :timep t))
1677 (let ((soa (zone-soa zone)))
1678 (tinydns-output #\Z
1679 (zone-name zone)
1680 (soa-source soa)
1681 (let* ((name (copy-seq (soa-admin soa)))
1682 (at (position #\@ name)))
1683 (when at (setf (char name at) #\.))
1684 name)
1685 (soa-serial soa)
1686 (soa-refresh soa)
1687 (soa-expire soa)
1688 (soa-min-ttl soa)
146571da 1689 (zone-default-ttl zone))))
e97012de 1690
7e282fb5 1691;;;----- That's all, folks --------------------------------------------------