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