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