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