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