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