chiark / gitweb /
Upgrade everything for SBCL.
[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 #:net-sys #:services)
31   (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain
32            #:*default-zone-source* #:*default-zone-refresh*
33              #:*default-zone-retry* #:*default-zone-expire*
34              #:*default-zone-min-ttl* #:*default-zone-ttl*
35              #:*default-mx-priority* #:*default-zone-admin*
36            #:*zone-output-path*
37            #:*preferred-subnets* #:zone-preferred-subnet-p
38            #:preferred-subnet-case
39            #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
40            #:defrevzone #:zone-save #:zone-make-name
41            #:defzoneparse #:zone-parse-host
42            #:bind-hostname #:bind-record #:bind-format-record
43            #:bind-record-type #:bind-record-format-args
44            #:timespec-seconds #:make-zone-serial))
45
46 (in-package #:zone)
47
48 ;;;--------------------------------------------------------------------------
49 ;;; Various random utilities.
50
51 (defun to-integer (x)
52   "Convert X to an integer in the most straightforward way."
53   (floor (rational x)))
54
55 (defun from-mixed-base (base val)
56   "BASE is a list of the ranges for the `digits' of a mixed-base
57    representation.  Convert VAL, a list of digits, into an integer."
58   (do ((base base (cdr base))
59        (val (cdr val) (cdr val))
60        (a (car val) (+ (* a (car base)) (car val))))
61       ((or (null base) (null val)) a)))
62
63 (defun to-mixed-base (base val)
64   "BASE is a list of the ranges for the `digits' of a mixed-base
65    representation.  Convert VAL, an integer, into a list of digits."
66   (let ((base (reverse base))
67         (a nil))
68     (loop
69       (unless base
70         (push val a)
71         (return a))
72       (multiple-value-bind (q r) (floor val (pop base))
73         (push r a)
74         (setf val q)))))
75
76 (defun timespec-seconds (ts)
77   "Convert a timespec TS to seconds.  A timespec may be a real count of
78    seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious
79    time units."
80   (cond ((null ts) 0)
81         ((realp ts) (floor ts))
82         ((atom ts)
83          (error "Unknown timespec format ~A" ts))
84         ((null (cdr ts))
85          (timespec-seconds (car ts)))
86         (t (+ (to-integer (* (car ts)
87                              (case (intern (string-upcase
88                                             (stringify (cadr ts)))
89                                            '#:zone)
90                                ((s sec secs second seconds) 1)
91                                ((m min mins minute minutes) 60)
92                                ((h hr hrs hour hours) #.(* 60 60))
93                                ((d dy dys day days) #.(* 24 60 60))
94                                ((w wk wks week weeks) #.(* 7 24 60 60))
95                                ((y yr yrs year years) #.(* 365 24 60 60))
96                                (t (error "Unknown time unit ~A"
97                                          (cadr ts))))))
98               (timespec-seconds (cddr ts))))))
99
100 (defun hash-table-keys (ht)
101   "Return a list of the keys in hashtable HT."
102   (collecting ()
103     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
104
105 (defun iso-date (&optional time &key datep timep (sep #\ ))
106   "Construct a textual date or time in ISO format.  The TIME is the universal
107    time to convert, which defaults to now; DATEP is whether to emit the date;
108    TIMEP is whether to emit the time, and SEP (default is space) is how to
109    separate the two."
110   (multiple-value-bind
111       (sec min hr day mon yr dow dstp tz)
112       (decode-universal-time (if (or (null time) (eq time :now))
113                                  (get-universal-time)
114                                  time))
115     (declare (ignore dow dstp tz))
116     (with-output-to-string (s)
117       (when datep
118         (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
119         (when timep
120           (write-char sep s)))
121       (when timep
122         (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
123
124 ;;;--------------------------------------------------------------------------
125 ;;; Zone types.
126
127 (defstruct (soa (:predicate soap))
128   "Start-of-authority record information."
129   source
130   admin
131   refresh
132   retry
133   expire
134   min-ttl
135   serial)
136
137 (defstruct (mx (:predicate mxp))
138   "Mail-exchange record information."
139   priority
140   domain)
141
142 (defstruct (zone (:predicate zonep))
143   "Zone information."
144   soa
145   default-ttl
146   name
147   records)
148
149 ;;;--------------------------------------------------------------------------
150 ;;; Zone defaults.  It is intended that scripts override these.
151
152 (defvar *default-zone-source*
153   (let ((hn (gethostname)))
154     (and hn (concatenate 'string (canonify-hostname hn) ".")))
155   "The default zone source: the current host's name.")
156
157 (defvar *default-zone-refresh* (* 24 60 60)
158   "Default zone refresh interval: one day.")
159
160 (defvar *default-zone-admin* nil
161   "Default zone administrator's email address.")
162
163 (defvar *default-zone-retry* (* 60 60)
164   "Default znoe retry interval: one hour.")
165
166 (defvar *default-zone-expire* (* 14 24 60 60)
167   "Default zone expiry time: two weeks.")
168
169 (defvar *default-zone-min-ttl* (* 4 60 60)
170   "Default zone minimum TTL/negative TTL: four hours.")
171
172 (defvar *default-zone-ttl* (* 8 60 60)
173   "Default zone TTL (for records without explicit TTLs): 8 hours.")
174
175 (defvar *default-mx-priority* 50
176   "Default MX priority.")
177
178 ;;;--------------------------------------------------------------------------
179 ;;; Zone variables and structures.
180
181 (defvar *zones* (make-hash-table :test #'equal)
182   "Map of known zones.")
183
184 (defun zone-find (name)
185   "Find a zone given its NAME."
186   (gethash (string-downcase (stringify name)) *zones*))
187
188 (defun (setf zone-find) (zone name)
189   "Make the zone NAME map to ZONE."
190   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
191
192 (defstruct (zone-record (:conc-name zr-))
193   "A zone record."
194   (name '<unnamed>)
195   ttl
196   type
197   (make-ptr-p nil)
198   data)
199
200 (defstruct (zone-subdomain (:conc-name zs-))
201   "A subdomain.  Slightly weird.  Used internally by zone-process-records
202    below, and shouldn't escape."
203   name
204   ttl
205   records)
206
207 (defvar *zone-output-path* *default-pathname-defaults*
208   "Pathname defaults to merge into output files.")
209
210 (defvar *preferred-subnets* nil
211   "Subnets to prefer when selecting defaults.")
212
213 ;;;--------------------------------------------------------------------------
214 ;;; Zone infrastructure.
215
216 (defun zone-file-name (zone type)
217   "Choose a file name for a given ZONE and TYPE."
218   (merge-pathnames (make-pathname :name (string-downcase zone)
219                                   :type (string-downcase type))
220                    *zone-output-path*))
221
222 (defun zone-preferred-subnet-p (name)
223   "Answer whether NAME (a string or symbol) names a preferred subnet."
224   (member name *preferred-subnets* :test #'string-equal))
225
226 (defmacro preferred-subnet-case (&body clauses)
227   "CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS whose
228    SUBNETS (a list or single symbol, not evaluated) are considered preferred
229    by zone-preferred-subnet-p.  If SUBNETS is the symbol t then the clause
230    always matches."
231   `(cond
232     ,@(mapcar (lambda (clause)
233                 (let ((subnets (car clause)))
234                   (cons (cond ((eq subnets t)
235                                t)
236                               ((listp subnets)
237                                `(or ,@(mapcar (lambda (subnet)
238                                                 `(zone-preferred-subnet-p
239                                                   ',subnet))
240                                               subnets)))
241                               (t
242                                `(zone-preferred-subnet-p ',subnets)))
243                         (cdr clause))))
244               clauses)))
245
246 (defun zone-process-records (rec ttl func)
247   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
248    the default time-to-live for records which don't specify one."
249   (labels ((sift (rec ttl)
250              (collecting (top sub)
251                (loop
252                  (unless rec
253                    (return))
254                  (let ((r (pop rec)))
255                    (cond ((eq r :ttl)
256                           (setf ttl (pop rec)))
257                          ((symbolp r)
258                           (collect (make-zone-record :type r
259                                                      :ttl ttl
260                                                      :data (pop rec))
261                                    top))
262                          ((listp r)
263                           (dolist (name (listify (car r)))
264                             (collect (make-zone-subdomain :name name
265                                                           :ttl ttl
266                                                           :records (cdr r))
267                                      sub)))
268                          (t
269                           (error "Unexpected record form ~A" (car r))))))))
270            (process (rec dom ttl)
271              (multiple-value-bind (top sub) (sift rec ttl)
272                (if (and dom (null top) sub)
273                    (let ((preferred nil))
274                      (dolist (s sub)
275                        (when (some #'zone-preferred-subnet-p
276                                    (listify (zs-name s)))
277                          (setf preferred s)))
278                      (unless preferred
279                        (setf preferred (car sub)))
280                      (when preferred
281                        (process (zs-records preferred)
282                                 dom
283                                 (zs-ttl preferred))))
284                    (let ((name (and dom
285                                     (string-downcase
286                                      (join-strings #\. (reverse dom))))))
287                      (dolist (zr top)
288                        (setf (zr-name zr) name)
289                        (funcall func zr))))
290                (dolist (s sub)
291                  (process (zs-records s)
292                           (cons (zs-name s) dom)
293                           (zs-ttl s))))))
294     (process rec nil ttl)))
295
296 (defun zone-parse-host (f zname)
297   "Parse a host name F: if F ends in a dot then it's considered absolute;
298    otherwise it's relative to ZNAME."
299   (setf f (stringify f))
300   (cond ((string= f "@") (stringify zname))
301         ((and (plusp (length f))
302               (char= (char f (1- (length f))) #\.))
303          (string-downcase (subseq f 0 (1- (length f)))))
304         (t (string-downcase (concatenate 'string f "."
305                                          (stringify zname))))))
306 (defun default-rev-zone (base bytes)
307   "Return the default reverse-zone name for the given BASE address and number
308    of fixed leading BYTES."
309   (join-strings #\. (collecting ()
310                       (loop for i from (- 3 bytes) downto 0
311                             do (collect (ipaddr-byte base i)))
312                       (collect "in-addr.arpa"))))
313
314 (defun zone-name-from-net (net &optional bytes)
315   "Given a NET, and maybe the BYTES to use, convert to the appropriate
316    subdomain of in-addr.arpa."
317   (let ((ipn (net-get-as-ipnet net)))
318     (with-ipnet (net mask) ipn
319       (unless bytes
320         (setf bytes (- 4 (ipnet-changeable-bytes mask))))
321       (join-strings #\.
322                     (append (loop
323                                for i from (- 4 bytes) below 4
324                                collect (logand #xff (ash net (* -8 i))))
325                             (list "in-addr.arpa"))))))
326
327 (defun zone-net-from-name (name)
328   "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
329   (let* ((name (string-downcase (stringify name)))
330          (len (length name))
331          (suffix ".in-addr.arpa")
332          (sufflen (length suffix))
333          (addr 0)
334          (n 0)
335          (end (- len sufflen)))
336     (unless (and (> len sufflen)
337                  (string= name suffix :start1 end))
338       (error "`~A' not in ~A." name suffix))
339     (loop
340        with start = 0
341        for dot = (position #\. name :start start :end end)
342        for byte = (parse-integer name
343                                  :start start
344                                  :end (or dot end))
345        do (setf addr (logior addr (ash byte (* 8 n))))
346           (incf n)
347        when (>= n 4)
348        do (error "Can't deduce network from ~A." name)
349        while dot
350        do (setf start (1+ dot)))
351     (setf addr (ash addr (* 8 (- 4 n))))
352     (make-ipnet addr (* 8 n))))
353
354 (defun zone-parse-net (net name)
355   "Given a NET, and the NAME of a domain to guess from if NET is null, return
356    the ipnet for the network."
357   (if net
358       (net-get-as-ipnet net)
359       (zone-net-from-name name)))
360
361 (defun zone-cidr-delg-default-name (ipn bytes)
362   "Given a delegated net IPN and the parent's number of changing BYTES,
363    return the default deletate zone prefix."
364   (with-ipnet (net mask) ipn
365     (join-strings #\.
366                   (reverse
367                    (loop
368                       for i from (1- bytes) downto 0
369                       until (zerop (logand mask (ash #xff (* 8 i))))
370                       collect (logand #xff (ash net (* -8 i))))))))
371
372 ;;;--------------------------------------------------------------------------
373 ;;; Serial numbering.
374
375 (defun make-zone-serial (name)
376   "Given a zone NAME, come up with a new serial number.  This will (very
377    carefully) update a file ZONE.serial in the current directory."
378   (let* ((file (zone-file-name name :serial))
379          (last (with-open-file (in file
380                                    :direction :input
381                                    :if-does-not-exist nil)
382                  (if in (read in)
383                      (list 0 0 0 0))))
384          (now (multiple-value-bind
385                   (sec min hr dy mon yr dow dstp tz)
386                   (get-decoded-time)
387                 (declare (ignore sec min hr dow dstp tz))
388                 (list dy mon yr)))
389          (seq (cond ((not (equal now (cdr last))) 0)
390                     ((< (car last) 99) (1+ (car last)))
391                     (t (error "Run out of sequence numbers for ~A" name)))))
392     (safely-writing (out file)
393       (format out
394               ";; Serial number file for zone ~A~%~
395                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
396                ~S~%"
397               name
398               (cons seq now)))
399     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
400
401 ;;;--------------------------------------------------------------------------
402 ;;; Zone form parsing.
403
404 (defun zone-parse-head (head)
405   "Parse the HEAD of a zone form.  This has the form
406
407      (NAME &key :source :admin :refresh :retry
408                 :expire :min-ttl :ttl :serial)
409
410    though a singleton NAME needn't be a list.  Returns the default TTL and an
411    soa structure representing the zone head."
412   (destructuring-bind
413       (zname
414        &key
415        (source *default-zone-source*)
416        (admin (or *default-zone-admin*
417                   (format nil "hostmaster@~A" zname)))
418        (refresh *default-zone-refresh*)
419        (retry *default-zone-retry*)
420        (expire *default-zone-expire*)
421        (min-ttl *default-zone-min-ttl*)
422        (ttl min-ttl)
423        (serial (make-zone-serial zname)))
424       (listify head)
425     (values zname
426             (timespec-seconds ttl)
427             (make-soa :admin admin
428                       :source (zone-parse-host source zname)
429                       :refresh (timespec-seconds refresh)
430                       :retry (timespec-seconds retry)
431                       :expire (timespec-seconds expire)
432                       :min-ttl (timespec-seconds min-ttl)
433                       :serial serial))))
434
435 (defun zone-make-name (prefix zone-name)
436   (if (or (not prefix) (string= prefix "@"))
437       zone-name
438       (let ((len (length prefix)))
439         (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
440             (join-strings #\. (list prefix zone-name))
441             prefix))))
442
443 (defmacro defzoneparse (types (name data list
444                                &key (prefix (gensym "PREFIX"))
445                                     (zname (gensym "ZNAME"))
446                                     (ttl (gensym "TTL")))
447                         &body body)
448   "Define a new zone record type (or TYPES -- a list of synonyms is
449    permitted).  The arguments are as follows:
450
451    NAME         The name of the record to be added.
452
453    DATA         The content of the record to be added (a single object,
454                 unevaluated).
455
456    LIST         A function to add a record to the zone.  See below.
457
458    PREFIX       The prefix tag used in the original form.
459
460    ZNAME        The name of the zone being constructed.
461
462    TTL          The TTL for this record.
463
464    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
465    optional: you don't have to accept them if you're not interested.
466
467    The LIST argument names a function to be bound in the body to add a new
468    low-level record to the zone.  It has the prototype
469
470      (LIST &key :name :type :data :ttl :make-ptr-p)
471
472    These (except MAKE-PTR-P, which defaults to nil) default to the above
473    arguments (even if you didn't accept the arguments)."
474   (setf types (listify types))
475   (let* ((type (car types))
476          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
477     (with-parsed-body (body decls doc) body
478       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
479         `(progn
480            (dolist (,i ',types)
481              (setf (get ,i 'zone-parse) ',func))
482            (defun ,func (,prefix ,zname ,data ,ttl ,col)
483              ,@doc
484              ,@decls
485              (let ((,name (zone-make-name ,prefix ,zname)))
486                (flet ((,list (&key ((:name ,tname) ,name)
487                                    ((:type ,ttype) ,type)
488                                    ((:data ,tdata) ,data)
489                                    ((:ttl ,tttl) ,ttl)
490                                    ((:make-ptr-p ,tmakeptrp) nil))
491                         #+cmu (declare (optimize ext:inhibit-warnings))
492                         (collect (make-zone-record :name ,tname
493                                                    :type ,ttype
494                                                    :data ,tdata
495                                                    :ttl ,tttl
496                                                    :make-ptr-p ,tmakeptrp)
497                                  ,col)))
498                  ,@body)))
499           ',type)))))
500
501 (defun zone-parse-records (zone records)
502   (let ((zname (zone-name zone)))
503     (with-collection (rec)
504         (flet ((parse-record (zr)
505                  (let ((func (or (get (zr-type zr) 'zone-parse)
506                                  (error "No parser for record ~A."
507                                         (zr-type zr))))
508                        (name (and (zr-name zr) (stringify (zr-name zr)))))
509                    (funcall func
510                             name
511                             zname
512                             (zr-data zr)
513                             (zr-ttl zr)
514                             rec))))
515           (zone-process-records records
516                                 (zone-default-ttl zone)
517                                 #'parse-record))
518       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
519
520 (defun zone-parse (zf)
521   "Parse a ZONE form.  The syntax of a zone form is as follows:
522
523    ZONE-FORM:
524      ZONE-HEAD ZONE-RECORD*
525
526    ZONE-RECORD:
527      ((NAME*) ZONE-RECORD*)
528    | SYM ARGS"
529   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
530     (let ((zone (make-zone :name zname
531                            :default-ttl ttl
532                            :soa soa
533                            :records nil)))
534       (zone-parse-records zone (cdr zf))
535       zone)))
536
537 (defun zone-create (zf)
538   "Zone construction function.  Given a zone form ZF, construct the zone and
539    add it to the table."
540   (let* ((zone (zone-parse zf))
541          (name (zone-name zone)))
542     (setf (zone-find name) zone)
543     name))
544
545 (defmacro defzone (soa &rest zf)
546   "Zone definition macro."
547   `(zone-create '(,soa ,@zf)))
548
549 (defmacro defrevzone (head &rest zf)
550   "Define a reverse zone, with the correct name."
551   (destructuring-bind
552       (net &rest soa-args)
553       (listify head)
554     (let ((bytes nil))
555       (when (and soa-args (integerp (car soa-args)))
556         (setf bytes (pop soa-args)))
557       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
558
559 ;;;--------------------------------------------------------------------------
560 ;;; Zone record parsers.
561
562 (defzoneparse :a (name data rec)
563   ":a IPADDR"
564   (rec :data (parse-ipaddr data) :make-ptr-p t))
565
566 (defzoneparse :svc (name data rec)
567   ":svc IPADDR"
568   (rec :type :a :data (parse-ipaddr data)))
569
570 (defzoneparse :ptr (name data rec :zname zname)
571   ":ptr HOST"
572   (rec :data (zone-parse-host data zname)))
573
574 (defzoneparse :cname (name data rec :zname zname)
575   ":cname HOST"
576   (rec :data (zone-parse-host data zname)))
577
578 (defzoneparse :mx (name data rec :zname zname)
579   ":mx ((HOST :prio INT :ip IPADDR)*)"
580   (dolist (mx (listify data))
581     (destructuring-bind
582         (mxname &key (prio *default-mx-priority*) ip)
583         (listify mx)
584       (let ((host (zone-parse-host mxname zname)))
585         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
586         (rec :data (cons host prio))))))
587
588 (defzoneparse :ns (name data rec :zname zname)
589   ":ns ((HOST :ip IPADDR)*)"
590   (dolist (ns (listify data))
591     (destructuring-bind
592         (nsname &key ip)
593         (listify ns)
594       (let ((host (zone-parse-host nsname zname)))
595         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
596         (rec :data host)))))
597
598 (defzoneparse :alias (name data rec :zname zname)
599   ":alias (LABEL*)"
600   (dolist (a (listify data))
601     (rec :name (zone-parse-host a zname)
602          :type :cname
603          :data name)))
604
605 (defzoneparse :srv (name data rec :zname zname)
606   ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)"
607   (dolist (srv data)
608     (destructuring-bind (servopts &rest providers) srv
609       (destructuring-bind
610           (service &key ((:port default-port)) (protocol :tcp))
611           (listify servopts)
612         (unless default-port
613           (let ((serv (serv-by-name service protocol)))
614             (setf default-port (and serv (serv-port serv)))))
615         (let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
616           (dolist (prov providers)
617             (destructuring-bind
618                 (srvname
619                  &key
620                  (port default-port)
621                  (prio *default-mx-priority*)
622                  (weight 0)
623                  ip)
624                 (listify prov)
625               (let ((host (zone-parse-host srvname zname)))
626                 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
627                 (rec :name rname
628                      :data (list prio weight port host))))))))))
629
630 (defzoneparse :net (name data rec)
631   ":net (NETWORK*)"
632   (dolist (net (listify data))
633     (let ((n (net-get-as-ipnet net)))
634       (rec :name (zone-parse-host "net" name)
635            :type :a
636            :data (ipnet-net n))
637       (rec :name (zone-parse-host "mask" name)
638            :type :a
639            :data (ipnet-mask n))
640       (rec :name (zone-parse-host "broadcast" name)
641            :type :a
642            :data (ipnet-broadcast n)))))
643
644 (defzoneparse (:rev :reverse) (name data rec)
645   ":reverse ((NET :bytes BYTES) ZONE*)"
646   (setf data (listify data))
647   (destructuring-bind (net &key bytes) (listify (car data))
648     (setf net (zone-parse-net net name))
649     (unless bytes
650       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
651     (let ((seen (make-hash-table :test #'equal)))
652       (dolist (z (or (cdr data)
653                      (hash-table-keys *zones*)))
654         (dolist (zr (zone-records (zone-find z)))
655           (when (and (eq (zr-type zr) :a)
656                      (zr-make-ptr-p zr)
657                      (ipaddr-networkp (zr-data zr) net))
658             (let ((name (string-downcase
659                          (join-strings
660                           #\.
661                           (collecting ()
662                             (dotimes (i bytes)
663                               (collect (logand #xff (ash (zr-data zr)
664                                                          (* -8 i)))))
665                             (collect name))))))
666               (unless (gethash name seen)
667                 (rec :name name :type :ptr
668                      :ttl (zr-ttl zr) :data (zr-name zr))
669                 (setf (gethash name seen) t)))))))))
670
671 (defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname)
672   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
673   (setf data (listify data))
674   (destructuring-bind (net &key bytes) (listify (car data))
675     (setf net (zone-parse-net net name))
676     (unless bytes
677       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
678     (dolist (map (or (cdr data) (list (list net))))
679       (destructuring-bind (tnet &optional tdom) (listify map)
680         (setf tnet (zone-parse-net tnet name))
681         (unless (ipnet-subnetp net tnet)
682           (error "~A is not a subnet of ~A."
683                  (ipnet-pretty tnet)
684                  (ipnet-pretty net)))
685         (unless tdom
686           (with-ipnet (net mask) tnet
687             (setf tdom
688                   (join-strings
689                    #\.
690                    (append (reverse (loop
691                                      for i from (1- bytes) downto 0
692                                      until (zerop (logand mask
693                                                           (ash #xff
694                                                                (* 8 i))))
695                                      collect (ldb (byte 8 (* i 8)) net)))
696                            (list name))))))
697         (setf tdom (string-downcase (stringify tdom)))
698         (dotimes (i (ipnet-hosts tnet))
699           (unless (zerop i)
700             (let* ((addr (ipnet-host tnet i))
701                    (tail (join-strings #\.
702                                        (loop
703                                         for i from 0 below bytes
704                                         collect
705                                         (logand #xff
706                                                 (ash addr (* 8 i)))))))
707               (rec :name (format nil "~A.~A" tail name)
708                    :type :cname
709                    :data (format nil "~A.~A" tail tdom)))))))))
710
711 ;;;--------------------------------------------------------------------------
712 ;;; Zone file output.
713
714 (defgeneric zone-write (format zone stream)
715   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
716
717 (defvar *writing-zone* nil
718   "The zone currently being written.")
719
720 (defvar *zone-output-stream* nil
721   "Stream to write zone data on.")
722
723 (defmethod zone-write :around (format zone stream)
724   (let ((*writing-zone* zone)
725         (*zone-output-stream* stream))
726     (call-next-method)))
727
728 (defun zone-save (zones &key (format :bind))
729   "Write the named ZONES to files.  If no zones are given, write all the
730    zones."
731   (unless zones
732     (setf zones (hash-table-keys *zones*)))
733   (safely (safe)
734     (dolist (z zones)
735       (let ((zz (zone-find z)))
736         (unless zz
737           (error "Unknown zone `~A'." z))
738         (let ((stream (safely-open-output-stream safe
739                                                  (zone-file-name z :zone))))
740           (zone-write format zz stream))))))
741
742 ;;;--------------------------------------------------------------------------
743 ;;; Bind format output.
744
745 (defun bind-hostname (hostname)
746   (if (not hostname)
747       "@"
748       (let* ((h (string-downcase (stringify hostname)))
749              (hl (length h))
750              (r (string-downcase (zone-name *writing-zone*)))
751              (rl (length r)))
752         (cond ((string= r h) "@")
753               ((and (> hl rl)
754                     (char= (char h (- hl rl 1)) #\.)
755                     (string= h r :start1 (- hl rl)))
756                (subseq h 0 (- hl rl 1)))
757               (t (concatenate 'string h "."))))))
758
759 (defmethod zone-write ((format (eql :bind)) zone stream)
760   (format stream "~
761 ;;; Zone file `~(~A~)'
762 ;;;   (generated ~A)
763
764 $ORIGIN ~0@*~(~A.~)
765 $TTL ~2@*~D~2%"
766             (zone-name zone)
767             (iso-date :now :datep t :timep t)
768             (zone-default-ttl zone))
769   (let* ((soa (zone-soa zone))
770          (admin (let* ((name (soa-admin soa))
771                        (at (position #\@ name))
772                        (copy (format nil "~(~A~)." name)))
773                   (when at
774                     (setf (char copy at) #\.))
775                   copy)))
776       (format stream "~
777 ~A~30TIN SOA~40T~A ~A (
778 ~45T~10D~60T ;serial
779 ~45T~10D~60T ;refresh
780 ~45T~10D~60T ;retry
781 ~45T~10D~60T ;expire
782 ~45T~10D )~60T ;min-ttl~2%"
783               (bind-hostname (zone-name zone))
784               (bind-hostname (soa-source soa))
785               admin
786               (soa-serial soa)
787               (soa-refresh soa)
788               (soa-retry soa)
789               (soa-expire soa)
790               (soa-min-ttl soa)))
791   (dolist (zr (zone-records zone))
792     (bind-record (zr-type zr) zr)))
793
794 (defgeneric bind-record (type zr))
795
796 (defun bind-format-record (name ttl type format args)
797   (format *zone-output-stream*
798           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
799           (bind-hostname name)
800           (and (/= ttl (zone-default-ttl *writing-zone*))
801                ttl)
802           (string-upcase (symbol-name type))
803           format args))
804
805 (defmethod bind-record (type zr)
806   (destructuring-bind (format &rest args)
807       (bind-record-format-args type (zr-data zr))
808     (bind-format-record (zr-name zr)
809                         (zr-ttl zr)
810                         (bind-record-type type)
811                         format args)))
812
813 (defgeneric bind-record-type (type)
814   (:method (type) type))
815
816 (defgeneric bind-record-format-args (type data)
817   (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
818   (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
819   (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
820   (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
821   (:method ((type (eql :mx)) data)
822     (list "~2D ~A" (cdr data) (bind-hostname (car data))))
823   (:method ((type (eql :srv)) data)
824     (destructuring-bind (prio weight port host) data
825       (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host))))
826   (:method ((type (eql :txt)) data) (list "~S" (stringify data))))
827
828 ;;;----- That's all, folks --------------------------------------------------