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