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