chiark / gitweb /
net.lisp, zone.lisp: Major overhaul for multiple address families.
[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 ;;;--------------------------------------------------------------------------
115 ;;; Zone types.
116
117 (export 'soa)
118 (defstruct (soa (:predicate soap))
119   "Start-of-authority record information."
120   source
121   admin
122   refresh
123   retry
124   expire
125   min-ttl
126   serial)
127
128 (export 'mx)
129 (defstruct (mx (:predicate mxp))
130   "Mail-exchange record information."
131   priority
132   domain)
133
134 (export 'zone)
135 (defstruct (zone (:predicate zonep))
136   "Zone information."
137   soa
138   default-ttl
139   name
140   records)
141
142 ;;;--------------------------------------------------------------------------
143 ;;; Zone defaults.  It is intended that scripts override these.
144
145 (export '*default-zone-source*)
146 (defvar *default-zone-source*
147   (let ((hn (gethostname)))
148     (and hn (concatenate 'string (canonify-hostname hn) ".")))
149   "The default zone source: the current host's name.")
150
151 (export '*default-zone-refresh*)
152 (defvar *default-zone-refresh* (* 24 60 60)
153   "Default zone refresh interval: one day.")
154
155 (export '*default-zone-admin*)
156 (defvar *default-zone-admin* nil
157   "Default zone administrator's email address.")
158
159 (export '*default-zone-retry*)
160 (defvar *default-zone-retry* (* 60 60)
161   "Default znoe retry interval: one hour.")
162
163 (export '*default-zone-expire*)
164 (defvar *default-zone-expire* (* 14 24 60 60)
165   "Default zone expiry time: two weeks.")
166
167 (export '*default-zone-min-ttl*)
168 (defvar *default-zone-min-ttl* (* 4 60 60)
169   "Default zone minimum TTL/negative TTL: four hours.")
170
171 (export '*default-zone-ttl*)
172 (defvar *default-zone-ttl* (* 8 60 60)
173   "Default zone TTL (for records without explicit TTLs): 8 hours.")
174
175 (export '*default-mx-priority*)
176 (defvar *default-mx-priority* 50
177   "Default MX priority.")
178
179 ;;;--------------------------------------------------------------------------
180 ;;; Zone variables and structures.
181
182 (defvar *zones* (make-hash-table :test #'equal)
183   "Map of known zones.")
184
185 (export 'zone-find)
186 (defun zone-find (name)
187   "Find a zone given its NAME."
188   (gethash (string-downcase (stringify name)) *zones*))
189 (defun (setf zone-find) (zone name)
190   "Make the zone NAME map to ZONE."
191   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
192
193 (export 'zone-record)
194 (defstruct (zone-record (:conc-name zr-))
195   "A zone record."
196   (name '<unnamed>)
197   ttl
198   type
199   (make-ptr-p nil)
200   data)
201
202 (export 'zone-subdomain)
203 (defstruct (zone-subdomain (:conc-name zs-))
204   "A subdomain.
205
206    Slightly weird.  Used internally by `zone-process-records', and shouldn't
207    escape."
208   name
209   ttl
210   records)
211
212 (export '*zone-output-path*)
213 (defvar *zone-output-path* nil
214   "Pathname defaults to merge into output files.
215
216    If this is nil then use the prevailing `*default-pathname-defaults*'.
217    This is not the same as capturing the `*default-pathname-defaults*' from
218    load time.")
219
220 (export '*preferred-subnets*)
221 (defvar *preferred-subnets* nil
222   "Subnets to prefer when selecting defaults.")
223
224 ;;;--------------------------------------------------------------------------
225 ;;; Zone infrastructure.
226
227 (defun zone-file-name (zone type)
228   "Choose a file name for a given ZONE and TYPE."
229   (merge-pathnames (make-pathname :name (string-downcase zone)
230                                   :type (string-downcase type))
231                    (or *zone-output-path* *default-pathname-defaults*)))
232
233 (export 'zone-preferred-subnet-p)
234 (defun zone-preferred-subnet-p (name)
235   "Answer whether NAME (a string or symbol) names a preferred subnet."
236   (member name *preferred-subnets* :test #'string-equal))
237
238 (export 'preferred-subnet-case)
239 (defmacro preferred-subnet-case (&body clauses)
240   "Execute a form based on which networks are considered preferred.
241
242    The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
243    whose SUBNETS (a list or single symbol, not evaluated) are listed in
244    `*preferred-subnets*'.  If SUBNETS is the symbol `t' then the clause
245    always matches."
246   `(cond
247     ,@(mapcar (lambda (clause)
248                 (let ((subnets (car clause)))
249                   (cons (cond ((eq subnets t)
250                                t)
251                               ((listp subnets)
252                                `(or ,@(mapcar (lambda (subnet)
253                                                 `(zone-preferred-subnet-p
254                                                   ',subnet))
255                                               subnets)))
256                               (t
257                                `(zone-preferred-subnet-p ',subnets)))
258                         (cdr clause))))
259               clauses)))
260
261 (export 'zone-parse-host)
262 (defun zone-parse-host (f zname)
263   "Parse a host name F.
264
265    If F ends in a dot then it's considered absolute; otherwise it's relative
266    to ZNAME."
267   (setf f (stringify f))
268   (cond ((string= f "@") (stringify zname))
269         ((and (plusp (length f))
270               (char= (char f (1- (length f))) #\.))
271          (string-downcase (subseq f 0 (1- (length f)))))
272         (t (string-downcase (concatenate 'string f "."
273                                          (stringify zname))))))
274
275 (export 'zone-make-name)
276 (defun zone-make-name (prefix zone-name)
277   "Compute a full domain name from a PREFIX and a ZONE-NAME.
278
279    If the PREFIX ends with `.' then it's absolute already; otherwise, append
280    the ZONE-NAME, separated with a `.'.  If PREFIX is nil, or `@', then
281    return the ZONE-NAME only."
282   (if (or (not prefix) (string= prefix "@"))
283       zone-name
284       (let ((len (length prefix)))
285         (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
286             (join-strings #\. (list prefix zone-name))
287             prefix))))
288
289 ;;;--------------------------------------------------------------------------
290 ;;; Serial numbering.
291
292 (export 'make-zone-serial)
293 (defun make-zone-serial (name)
294   "Given a zone NAME, come up with a new serial number.
295
296    This will (very carefully) update a file ZONE.serial in the current
297    directory."
298   (let* ((file (zone-file-name name :serial))
299          (last (with-open-file (in file
300                                    :direction :input
301                                    :if-does-not-exist nil)
302                  (if in (read in)
303                      (list 0 0 0 0))))
304          (now (multiple-value-bind
305                   (sec min hr dy mon yr dow dstp tz)
306                   (get-decoded-time)
307                 (declare (ignore sec min hr dow dstp tz))
308                 (list dy mon yr)))
309          (seq (cond ((not (equal now (cdr last))) 0)
310                     ((< (car last) 99) (1+ (car last)))
311                     (t (error "Run out of sequence numbers for ~A" name)))))
312     (safely-writing (out file)
313       (format out
314               ";; Serial number file for zone ~A~%~
315                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
316                ~S~%"
317               name
318               (cons seq now)))
319     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
320
321 ;;;--------------------------------------------------------------------------
322 ;;; Zone form parsing.
323
324 (defun zone-process-records (rec ttl func)
325   "Sort out the list of records in REC, calling FUNC for each one.
326
327    TTL is the default time-to-live for records which don't specify one.
328
329    REC is a list of records of the form
330
331         ({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)
332
333    The various kinds of entries have the following meanings.
334
335    :ttl TTL             Set the TTL for subsequent records (at this level of
336                           nesting only).
337
338    TYPE DATA            Define a record with a particular TYPE and DATA.
339                           Record types are defined using `defzoneparse' and
340                           the syntax of the data is idiosyncratic.
341
342    ((LABEL ...) . REC)  Define records for labels within the zone.  Any
343                           records defined within REC will have their domains
344                           prefixed by each of the LABELs.  A singleton list
345                           of labels may instead be written as a single
346                           label.  Note, therefore, that
347
348                                 (host (sub :a \"169.254.1.1\"))
349
350                           defines a record for `host.sub' -- not `sub.host'.
351
352    If REC contains no top-level records, but it does define records for a
353    label listed in `*preferred-subnets*', then the records for the first such
354    label are also promoted to top-level.
355
356    The FUNC is called for each record encountered, represented as a
357    `zone-record' object.  Zone parsers are not called: you get the record
358    types and data from the input form; see `zone-parse-records' if you want
359    the raw output."
360
361   (labels ((sift (rec ttl)
362              ;; Parse the record list REC into lists of `zone-record' and
363              ;; `zone-subdomain' objects, sorting out TTLs and so on.
364              ;; Returns them as two values.
365
366              (collecting (top sub)
367                (loop
368                  (unless rec
369                    (return))
370                  (let ((r (pop rec)))
371                    (cond ((eq r :ttl)
372                           (setf ttl (pop rec)))
373                          ((symbolp r)
374                           (collect (make-zone-record :type r
375                                                      :ttl ttl
376                                                      :data (pop rec))
377                                    top))
378                          ((listp r)
379                           (dolist (name (listify (car r)))
380                             (collect (make-zone-subdomain :name name
381                                                           :ttl ttl
382                                                           :records (cdr r))
383                                      sub)))
384                          (t
385                           (error "Unexpected record form ~A" (car r))))))))
386
387            (process (rec dom ttl)
388              ;; Recursirvely process the record list REC, with a list DOM of
389              ;; prefix labels, and a default TTL.  Promote records for a
390              ;; preferred subnet to toplevel if there are no toplevel records
391              ;; already.
392
393              (multiple-value-bind (top sub) (sift rec ttl)
394                (if (and dom (null top) sub)
395                    (let ((preferred
396                           (or (find-if (lambda (s)
397                                          (some #'zone-preferred-subnet-p
398                                                (listify (zs-name s))))
399                                        sub)
400                               (car sub))))
401                      (when preferred
402                        (process (zs-records preferred)
403                                 dom
404                                 (zs-ttl preferred))))
405                    (let ((name (and dom
406                                     (string-downcase
407                                      (join-strings #\. (reverse dom))))))
408                      (dolist (zr top)
409                        (setf (zr-name zr) name)
410                        (funcall func zr))))
411                (dolist (s sub)
412                  (process (zs-records s)
413                           (cons (zs-name s) dom)
414                           (zs-ttl s))))))
415
416     ;; Process the records we're given with no prefix.
417     (process rec nil ttl)))
418
419 (defun zone-parse-head (head)
420   "Parse the HEAD of a zone form.
421
422    This has the form
423
424      (NAME &key :source :admin :refresh :retry
425                 :expire :min-ttl :ttl :serial)
426
427    though a singleton NAME needn't be a list.  Returns the default TTL and an
428    soa structure representing the zone head."
429   (destructuring-bind
430       (zname
431        &key
432        (source *default-zone-source*)
433        (admin (or *default-zone-admin*
434                   (format nil "hostmaster@~A" zname)))
435        (refresh *default-zone-refresh*)
436        (retry *default-zone-retry*)
437        (expire *default-zone-expire*)
438        (min-ttl *default-zone-min-ttl*)
439        (ttl min-ttl)
440        (serial (make-zone-serial zname)))
441       (listify head)
442     (values zname
443             (timespec-seconds ttl)
444             (make-soa :admin admin
445                       :source (zone-parse-host source zname)
446                       :refresh (timespec-seconds refresh)
447                       :retry (timespec-seconds retry)
448                       :expire (timespec-seconds expire)
449                       :min-ttl (timespec-seconds min-ttl)
450                       :serial serial))))
451
452 (export 'defzoneparse)
453 (defmacro defzoneparse (types (name data list
454                                &key (prefix (gensym "PREFIX"))
455                                     (zname (gensym "ZNAME"))
456                                     (ttl (gensym "TTL")))
457                         &body body)
458   "Define a new zone record type.
459
460    The arguments are as follows:
461
462    TYPES        A singleton type symbol, or a list of aliases.
463
464    NAME         The name of the record to be added.
465
466    DATA         The content of the record to be added (a single object,
467                 unevaluated).
468
469    LIST         A function to add a record to the zone.  See below.
470
471    PREFIX       The prefix tag used in the original form.
472
473    ZNAME        The name of the zone being constructed.
474
475    TTL          The TTL for this record.
476
477    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
478    optional: you don't have to accept them if you're not interested.
479
480    The LIST argument names a function to be bound in the body to add a new
481    low-level record to the zone.  It has the prototype
482
483      (LIST &key :name :type :data :ttl :make-ptr-p)
484
485    These (except MAKE-PTR-P, which defaults to nil) default to the above
486    arguments (even if you didn't accept the arguments)."
487   (setf types (listify types))
488   (let* ((type (car types))
489          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
490     (with-parsed-body (body decls doc) body
491       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
492         `(progn
493            (dolist (,i ',types)
494              (setf (get ,i 'zone-parse) ',func))
495            (defun ,func (,prefix ,zname ,data ,ttl ,col)
496              ,@doc
497              ,@decls
498              (let ((,name (zone-make-name ,prefix ,zname)))
499                (flet ((,list (&key ((:name ,tname) ,name)
500                                    ((:type ,ttype) ,type)
501                                    ((:data ,tdata) ,data)
502                                    ((:ttl ,tttl) ,ttl)
503                                    ((:make-ptr-p ,tmakeptrp) nil))
504                         #+cmu (declare (optimize ext:inhibit-warnings))
505                         (collect (make-zone-record :name ,tname
506                                                    :type ,ttype
507                                                    :data ,tdata
508                                                    :ttl ,tttl
509                                                    :make-ptr-p ,tmakeptrp)
510                                  ,col)))
511                  ,@body)))
512            ',type)))))
513
514 (export 'zone-parse-records)
515 (defun zone-parse-records (zname ttl records)
516   "Parse a sequence of RECORDS and return a list of raw records.
517
518    The records are parsed relative to the zone name ZNAME, and using the
519    given default TTL."
520   (collecting (rec)
521     (flet ((parse-record (zr)
522              (let ((func (or (get (zr-type zr) 'zone-parse)
523                              (error "No parser for record ~A."
524                                     (zr-type zr))))
525                    (name (and (zr-name zr) (stringify (zr-name zr)))))
526                (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
527       (zone-process-records records ttl #'parse-record))))
528
529 (export 'zone-parse)
530 (defun zone-parse (zf)
531   "Parse a ZONE form.
532
533    The syntax of a zone form is as follows:
534
535    ZONE-FORM:
536      ZONE-HEAD ZONE-RECORD*
537
538    ZONE-RECORD:
539      ((NAME*) ZONE-RECORD*)
540    | SYM ARGS"
541   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
542     (make-zone :name zname
543                :default-ttl ttl
544                :soa soa
545                :records (zone-parse-records zname ttl (cdr zf)))))
546
547 (export 'zone-create)
548 (defun zone-create (zf)
549   "Zone construction function.  Given a zone form ZF, construct the zone and
550    add it to the table."
551   (let* ((zone (zone-parse zf))
552          (name (zone-name zone)))
553     (setf (zone-find name) zone)
554     name))
555
556 (export 'defzone)
557 (defmacro defzone (soa &body zf)
558   "Zone definition macro."
559   `(zone-create '(,soa ,@zf)))
560
561 (export '*address-family*)
562 (defvar *address-family* t
563   "The default address family.  This is bound by `defrevzone'.")
564
565 (export 'defrevzone)
566 (defmacro defrevzone (head &body zf)
567   "Define a reverse zone, with the correct name."
568   (destructuring-bind (nets &rest args
569                             &key &allow-other-keys
570                                  (family '*address-family*)
571                                  prefix-bits)
572       (listify head)
573     (with-gensyms (ipn)
574       `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
575          (let ((*address-family* (ipnet-family ,ipn)))
576            (zone-create `((,(reverse-domain ,ipn ,prefix-bits)
577                             ,@',(loop for (k v) on args by #'cddr
578                                       unless (member k
579                                                      '(:family :prefix-bits))
580                                       nconc (list k v)))
581                           ,@',zf)))))))
582
583 (defun map-host-addresses (func addr &key (family *address-family*))
584   "Call FUNC for each address denoted by ADDR (a `host-parse' address)."
585
586   (dolist (a (host-addrs (host-parse addr family)))
587     (funcall func a)))
588
589 (defmacro do-host ((addr spec &key (family *address-family*)) &body body)
590   "Evaluate BODY, binding ADDR to each address denoted by SPEC."
591   `(dolist (,addr (host-addrs (host-parse ,spec ,family)))
592      ,@body))
593
594 (export 'zone-set-address)
595 (defun zone-set-address (rec addrspec &rest args
596                          &key (family *address-family*) name ttl make-ptr-p)
597   "Write records (using REC) defining addresses for ADDRSPEC."
598   (declare (ignore name ttl make-ptr-p))
599   (let ((key-args (loop for (k v) on args by #'cddr
600                         unless (eq k :family)
601                         nconc (list k v))))
602     (do-host (addr addrspec :family family)
603       (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))
604
605 ;;;--------------------------------------------------------------------------
606 ;;; Zone record parsers.
607
608 (defzoneparse :a (name data rec)
609   ":a IPADDR"
610   (zone-set-address #'rec data :make-ptr-p t :family :ipv4))
611
612 (defzoneparse :addr (name data rec)
613   ":addr IPADDR"
614   (zone-set-address #'rec data :make-ptr-p t))
615
616 (defzoneparse :svc (name data rec)
617   ":svc IPADDR"
618   (zone-set-address #'rec data))
619
620 (defzoneparse :ptr (name data rec :zname zname)
621   ":ptr HOST"
622   (rec :data (zone-parse-host data zname)))
623
624 (defzoneparse :cname (name data rec :zname zname)
625   ":cname HOST"
626   (rec :data (zone-parse-host data zname)))
627
628 (defzoneparse :txt (name data rec)
629   ":txt TEXT"
630   (rec :data data))
631
632 (export '*dkim-pathname-defaults*)
633 (defvar *dkim-pathname-defaults*
634   (make-pathname :directory '(:relative "keys")
635                  :type "dkim"))
636
637 (defzoneparse :dkim (name data rec)
638   ":dkim (KEYFILE {:TAG VALUE}*)"
639   (destructuring-bind (file &rest plist) (listify data)
640     (let ((things nil) (out nil))
641       (labels ((flush ()
642                  (when out
643                    (push (get-output-stream-string out) things)
644                    (setf out nil)))
645                (emit (text)
646                  (let ((len (length text)))
647                    (when (and out (> (+ (file-position out)
648                                         (length text))
649                                      64))
650                      (flush))
651                    (when (plusp len)
652                      (cond ((< len 64)
653                             (unless out (setf out (make-string-output-stream)))
654                             (write-string text out))
655                            (t
656                             (do ((i 0 j)
657                                  (j 64 (+ j 64)))
658                                 ((>= i len))
659                               (push (subseq text i (min j len)) things))))))))
660         (do ((p plist (cddr p)))
661             ((endp p))
662           (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
663         (emit (with-output-to-string (out)
664                 (write-string "p=" out)
665                 (when file
666                   (with-open-file
667                       (in (merge-pathnames file *dkim-pathname-defaults*))
668                     (loop
669                       (when (string= (read-line in)
670                                      "-----BEGIN PUBLIC KEY-----")
671                         (return)))
672                     (loop
673                       (let ((line (read-line in)))
674                         (if (string= line "-----END PUBLIC KEY-----")
675                             (return)
676                             (write-string line out)))))))))
677       (rec :type :txt
678            :data (nreverse things)))))
679
680 (eval-when (:load-toplevel :execute)
681   (dolist (item '((sshfp-algorithm rsa 1)
682                   (sshfp-algorithm dsa 2)
683                   (sshfp-algorithm ecdsa 3)
684                   (sshfp-type sha-1 1)
685                   (sshfp-type sha-256 2)))
686     (destructuring-bind (prop sym val) item
687       (setf (get sym prop) val)
688       (export sym))))
689
690 (export '*sshfp-pathname-defaults*)
691 (defvar *sshfp-pathname-defaults*
692   (make-pathname :directory '(:relative "keys")
693                  :type "sshfp"))
694
695 (defzoneparse :sshfp (name data rec)
696   ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
697   (if (stringp data)
698       (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
699         (loop (let ((line (read-line in nil)))
700                 (unless line (return))
701                 (let ((words (str-split-words line)))
702                   (pop words)
703                   (when (string= (car words) "IN") (pop words))
704                   (unless (and (string= (car words) "SSHFP")
705                                (= (length words) 4))
706                     (error "Invalid SSHFP record."))
707                   (pop words)
708                   (destructuring-bind (alg type fpr) words
709                     (rec :data (list (parse-integer alg)
710                                      (parse-integer type)
711                                      fpr)))))))
712       (flet ((lookup (what prop)
713                (etypecase what
714                  (fixnum what)
715                  (symbol (or (get what prop)
716                              (error "~S is not a known ~A" what prop))))))
717         (dolist (item (listify data))
718           (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
719               (listify item)
720             (rec :data (list (lookup alg 'sshfp-algorithm)
721                              (lookup type 'sshfp-type)
722                              fpr)))))))
723
724 (defzoneparse :mx (name data rec :zname zname)
725   ":mx ((HOST :prio INT :ip IPADDR)*)"
726   (dolist (mx (listify data))
727     (destructuring-bind
728         (mxname &key (prio *default-mx-priority*) ip)
729         (listify mx)
730       (let ((host (zone-parse-host mxname zname)))
731         (when ip (zone-set-address #'rec ip :name host))
732         (rec :data (cons host prio))))))
733
734 (defzoneparse :ns (name data rec :zname zname)
735   ":ns ((HOST :ip IPADDR)*)"
736   (dolist (ns (listify data))
737     (destructuring-bind
738         (nsname &key ip)
739         (listify ns)
740       (let ((host (zone-parse-host nsname zname)))
741         (when ip (zone-set-address #'rec ip :name host))
742         (rec :data host)))))
743
744 (defzoneparse :alias (name data rec :zname zname)
745   ":alias (LABEL*)"
746   (dolist (a (listify data))
747     (rec :name (zone-parse-host a zname)
748          :type :cname
749          :data name)))
750
751 (defzoneparse :srv (name data rec :zname zname)
752   ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
753   (dolist (srv data)
754     (destructuring-bind (servopts &rest providers) srv
755       (destructuring-bind
756           (service &key ((:port default-port)) (protocol :tcp))
757           (listify servopts)
758         (unless default-port
759           (let ((serv (serv-by-name service protocol)))
760             (setf default-port (and serv (serv-port serv)))))
761         (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
762           (dolist (prov providers)
763             (destructuring-bind
764                 (srvname
765                  &key
766                  (port default-port)
767                  (prio *default-mx-priority*)
768                  (weight 0)
769                  ip)
770                 (listify prov)
771               (let ((host (zone-parse-host srvname zname)))
772                 (when ip (zone-set-address #'rec ip :name host))
773                 (rec :name rname
774                      :data (list prio weight port host))))))))))
775
776 (defzoneparse :net (name data rec)
777   ":net (NETWORK*)"
778   (dolist (net (listify data))
779     (dolist (ipn (net-ipnets (net-must-find net)))
780       (let* ((base (ipnet-net ipn))
781              (rrtype (ipaddr-rrtype base)))
782         (flet ((frob (kind addr)
783                  (when addr
784                    (rec :name (zone-parse-host kind name)
785                         :type rrtype
786                         :data addr))))
787           (frob "net" base)
788           (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn)))
789           (frob "bcast" (ipnet-broadcast ipn)))))))
790
791 (defzoneparse (:rev :reverse) (name data rec)
792   ":reverse ((NET &key :prefix-bits :family) ZONE*)
793
794    Add a reverse record each host in the ZONEs (or all zones) that lies
795    within NET."
796   (setf data (listify data))
797   (destructuring-bind (net &key prefix-bits (family *address-family*))
798       (listify (car data))
799
800     (dolist (ipn (net-parse-to-ipnets net family))
801       (let* ((seen (make-hash-table :test #'equal))
802              (width (ipnet-width ipn))
803              (frag-len (if prefix-bits (- width prefix-bits)
804                            (ipnet-changeable-bits width (ipnet-mask ipn)))))
805         (dolist (z (or (cdr data) (hash-table-keys *zones*)))
806           (dolist (zr (zone-records (zone-find z)))
807             (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn)))
808                        (zr-make-ptr-p zr)
809                        (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
810               (let* ((frag (reverse-domain-fragment (zr-data zr)
811                                                     0 frag-len))
812                      (name (concatenate 'string frag "." name)))
813                 (unless (gethash name seen)
814                   (rec :name name :type :ptr
815                        :ttl (zr-ttl zr) :data (zr-name zr))
816                   (setf (gethash name seen) t))))))))))
817
818 (defzoneparse (:multi) (name data rec :zname zname :ttl ttl)
819   ":multi (((NET*) &key :start :end :family :suffix) . REC)
820
821    Output multiple records covering a portion of the reverse-resolution
822    namespace corresponding to the particular NETs.  The START and END bounds
823    default to the most significant variable component of the
824    reverse-resolution domain.
825
826    The REC tail is a sequence of record forms (as handled by
827    `zone-process-records') to be emitted for each covered address.  Within
828    the bodies of these forms, the symbol `*' will be replaced by the
829    domain-name fragment corresponding to the current host, optionally
830    followed by the SUFFIX.
831
832    Examples:
833
834         (:multi ((delegated-subnet :start 8)
835                  :ns (some.ns.delegated.example :ip \"169.254.5.2\")))
836
837         (:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\")
838                  :cname *))
839
840    Obviously, nested `:multi' records won't work well."
841
842   (destructuring-bind (nets &key start end (family *address-family*) suffix)
843       (listify (car data))
844     (dolist (net (listify nets))
845       (dolist (ipn (net-parse-to-ipnets net family))
846         (let* ((addr (ipnet-net ipn))
847                (width (ipaddr-width addr))
848                (comp-width (reverse-domain-component-width addr))
849                (end (round-up (or end
850                                   (ipnet-changeable-bits width
851                                                          (ipnet-mask ipn)))
852                               comp-width))
853                (start (round-down (or start (- end comp-width))
854                                   comp-width))
855                (map (ipnet-host-map ipn)))
856           (multiple-value-bind (host-step host-limit)
857               (ipnet-index-bounds map start end)
858             (do ((index 0 (+ index host-step)))
859                 ((> index host-limit))
860               (let* ((addr (ipnet-index-host map index))
861                      (frag (reverse-domain-fragment addr start end))
862                      (target (concatenate 'string
863                                           (zone-make-name
864                                            (if (not suffix) frag
865                                                (concatenate 'string
866                                                             frag "." suffix))
867                                            zname)
868                                           ".")))
869                 (dolist (zr (zone-parse-records (zone-make-name frag zname)
870                                                 ttl
871                                                 (subst target '*
872                                                        (cdr data))))
873                   (rec :name (zr-name zr)
874                        :type (zr-type zr)
875                        :data (zr-data zr)
876                        :ttl (zr-ttl zr)
877                        :make-ptr-p (zr-make-ptr-p zr)))))))))))
878
879 ;;;--------------------------------------------------------------------------
880 ;;; Zone file output.
881
882 (export 'zone-write)
883 (defgeneric zone-write (format zone stream)
884   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
885
886 (defvar *writing-zone* nil
887   "The zone currently being written.")
888
889 (defvar *zone-output-stream* nil
890   "Stream to write zone data on.")
891
892 (defmethod zone-write :around (format zone stream)
893   (declare (ignore format))
894   (let ((*writing-zone* zone)
895         (*zone-output-stream* stream))
896     (call-next-method)))
897
898 (export 'zone-save)
899 (defun zone-save (zones &key (format :bind))
900   "Write the named ZONES to files.  If no zones are given, write all the
901    zones."
902   (unless zones
903     (setf zones (hash-table-keys *zones*)))
904   (safely (safe)
905     (dolist (z zones)
906       (let ((zz (zone-find z)))
907         (unless zz
908           (error "Unknown zone `~A'." z))
909         (let ((stream (safely-open-output-stream safe
910                                                  (zone-file-name z :zone))))
911           (zone-write format zz stream))))))
912
913 ;;;--------------------------------------------------------------------------
914 ;;; Bind format output.
915
916 (export 'bind-hostname)
917 (defun bind-hostname (hostname)
918   (if (not hostname)
919       "@"
920       (let* ((h (string-downcase (stringify hostname)))
921              (hl (length h))
922              (r (string-downcase (zone-name *writing-zone*)))
923              (rl (length r)))
924         (cond ((string= r h) "@")
925               ((and (> hl rl)
926                     (char= (char h (- hl rl 1)) #\.)
927                     (string= h r :start1 (- hl rl)))
928                (subseq h 0 (- hl rl 1)))
929               (t (concatenate 'string h "."))))))
930
931 (export 'bind-record)
932 (defgeneric bind-record (type zr))
933
934 (defmethod zone-write ((format (eql :bind)) zone stream)
935   (format stream "~
936 ;;; Zone file `~(~A~)'
937 ;;;   (generated ~A)
938
939 $ORIGIN ~0@*~(~A.~)
940 $TTL ~2@*~D~2%"
941             (zone-name zone)
942             (iso-date :now :datep t :timep t)
943             (zone-default-ttl zone))
944   (let* ((soa (zone-soa zone))
945          (admin (let* ((name (soa-admin soa))
946                        (at (position #\@ name))
947                        (copy (format nil "~(~A~)." name)))
948                   (when at
949                     (setf (char copy at) #\.))
950                   copy)))
951       (format stream "~
952 ~A~30TIN SOA~40T~A ~A (
953 ~45T~10D~60T ;serial
954 ~45T~10D~60T ;refresh
955 ~45T~10D~60T ;retry
956 ~45T~10D~60T ;expire
957 ~45T~10D )~60T ;min-ttl~2%"
958               (bind-hostname (zone-name zone))
959               (bind-hostname (soa-source soa))
960               admin
961               (soa-serial soa)
962               (soa-refresh soa)
963               (soa-retry soa)
964               (soa-expire soa)
965               (soa-min-ttl soa)))
966   (dolist (zr (zone-records zone))
967     (bind-record (zr-type zr) zr)))
968
969 (export 'bind-format-record)
970 (defun bind-format-record (name ttl type format args)
971   (format *zone-output-stream*
972           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
973           (bind-hostname name)
974           (and (/= ttl (zone-default-ttl *writing-zone*))
975                ttl)
976           (string-upcase (symbol-name type))
977           format args))
978
979 (export 'bind-record-type)
980 (defgeneric bind-record-type (type)
981   (:method (type) type))
982
983 (export 'bind-record-format-args)
984 (defgeneric bind-record-format-args (type data)
985   (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
986   (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
987   (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
988   (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
989   (:method ((type (eql :mx)) data)
990     (list "~2D ~A" (cdr data) (bind-hostname (car data))))
991   (:method ((type (eql :srv)) data)
992     (destructuring-bind (prio weight port host) data
993       (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
994   (:method ((type (eql :sshfp)) data)
995     (cons "~2D ~2D ~A" data))
996   (:method ((type (eql :txt)) data)
997     (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
998           (mapcar #'stringify (listify data)))))
999
1000 (defmethod bind-record (type zr)
1001   (destructuring-bind (format &rest args)
1002       (bind-record-format-args type (zr-data zr))
1003     (bind-format-record (zr-name zr)
1004                         (zr-ttl zr)
1005                         (bind-record-type type)
1006                         format args)))
1007
1008 ;;;----- That's all, folks --------------------------------------------------