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