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