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 (defun zone-cidr-delegation (data name ttl list)
 383   "Given :cidr-delegation info DATA, for a record called NAME and the current
 384    TTL, write lots of CNAME records to LIST."
 385   (destructuring-bind
 386       (net &key bytes)
 387       (listify (car data))
 388     (setf net (zone-parse-net net name))
 389     (unless bytes
 390       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 391     (dolist (map (cdr data))
 392       (destructuring-bind
 393           (tnet &optional tdom)
 394           (listify map)
 395         (setf tnet (zone-parse-net tnet name))
 396         (unless (ipnet-subnetp net tnet)
 397           (error "~A is not a subnet of ~A."
 398                  (ipnet-pretty tnet)
 399                  (ipnet-pretty net)))
 400         (unless tdom
 401           (setf tdom
 402                 (join-strings #\.
 403                               (list (zone-cidr-delg-default-name tnet bytes)
 404                                     name))))
 405         (setf tdom (string-downcase tdom))
 406         (dotimes (i (ipnet-hosts tnet))
 407           (let* ((addr (ipnet-host tnet i))
 408                  (tail (join-strings #\.
 409                                      (loop
 410                                         for i from 0 below bytes
 411                                         collect
 412                                           (logand #xff
 413                                                   (ash addr (* 8 i)))))))
 414             (collect (make-zone-record
 415                       :name (join-strings #\.
 416                                           (list tail name))
 417                       :type :cname
 418                       :ttl ttl
 419                       :data (join-strings #\. (list tail tdom)))
 420                      list)))))))
 421
 422 ;;;--------------------------------------------------------------------------
 423 ;;; Serial numbering.
 424
 425 (defun make-zone-serial (name)
 426   "Given a zone NAME, come up with a new serial number.  This will (very
 427    carefully) update a file ZONE.serial in the current directory."
 428   (let* ((file (zone-file-name name :serial))
 429          (last (with-open-file (in file
 430                                    :direction :input
 431                                    :if-does-not-exist nil)
 432                  (if in (read in)
 433                      (list 0 0 0 0))))
 434          (now (multiple-value-bind
 435                   (sec min hr dy mon yr dow dstp tz)
 436                   (get-decoded-time)
 437                 (declare (ignore sec min hr dow dstp tz))
 438                 (list dy mon yr)))
 439          (seq (cond ((not (equal now (cdr last))) 0)
 440                     ((< (car last) 99) (1+ (car last)))
 441                     (t (error "Run out of sequence numbers for ~A" name)))))
 442     (safely-writing (out file)
 443       (format out
 444               ";; Serial number file for zone ~A~%~
 445                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 446                ~S~%"
 447               name
 448               (cons seq now)))
 449     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 450
 451 ;;;--------------------------------------------------------------------------
 452 ;;; Zone form parsing.
 453
 454 (defun zone-parse-head (head)
 455   "Parse the HEAD of a zone form.  This has the form
 456
 457      (NAME &key :source :admin :refresh :retry
 458                 :expire :min-ttl :ttl :serial)
 459
 460    though a singleton NAME needn't be a list.  Returns the default TTL and an
 461    soa structure representing the zone head."
 462   (destructuring-bind
 463       (zname
 464        &key
 465        (source *default-zone-source*)
 466        (admin (or *default-zone-admin*
 467                   (format nil "hostmaster@~A" zname)))
 468        (refresh *default-zone-refresh*)
 469        (retry *default-zone-retry*)
 470        (expire *default-zone-expire*)
 471        (min-ttl *default-zone-min-ttl*)
 472        (ttl min-ttl)
 473        (serial (make-zone-serial zname)))
 474       (listify head)
 475     (values zname
 476             (timespec-seconds ttl)
 477             (make-soa :admin admin
 478                       :source (zone-parse-host source zname)
 479                       :refresh (timespec-seconds refresh)
 480                       :retry (timespec-seconds retry)
 481                       :expire (timespec-seconds expire)
 482                       :min-ttl (timespec-seconds min-ttl)
 483                       :serial serial))))
 484
 485 (defun zone-make-name (prefix zone-name)
 486   (if (or (not prefix) (string= prefix "@"))
 487       zone-name
 488       (let ((len (length prefix)))
 489         (if (or (zerop len) (char/= (char prefix (1- len)) #\.))
 490             (join-strings #\. (list prefix zone-name))
 491             prefix))))
 492
 493 (defmacro defzoneparse (types (name data list
 494                                &key (prefix (gensym "PREFIX"))
 495                                     (zname (gensym "ZNAME"))
 496                                     (ttl (gensym "TTL")))
 497                         &body body)
 498   "Define a new zone record type (or TYPES -- a list of synonyms is
 499    permitted).  The arguments are as follows:
 500
 501    NAME         The name of the record to be added.
 502
 503    DATA         The content of the record to be added (a single object,
 504                 unevaluated).
 505
 506    LIST         A function to add a record to the zone.  See below.
 507
 508    PREFIX       The prefix tag used in the original form.
 509
 510    ZNAME        The name of the zone being constructed.
 511
 512    TTL          The TTL for this record.
 513
 514    You get to choose your own names for these.  ZNAME, PREFIX and TTL are
 515    optional: you don't have to accept them if you're not interested.
 516
 517    The LIST argument names a function to be bound in the body to add a new
 518    low-level record to the zone.  It has the prototype
 519
 520      (LIST &key :name :type :data :ttl :make-ptr-p)
 521
 522    These (except MAKE-PTR-P, which defaults to nil) default to the above
 523    arguments (even if you didn't accept the arguments)."
 524   (setf types (listify types))
 525   (let* ((type (car types))
 526          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 527     (with-parsed-body (body decls doc) body
 528       (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
 529         `(progn
 530            (dolist (,i ',types)
 531              (setf (get ,i 'zone-parse) ',func))
 532            (defun ,func (,prefix ,zname ,data ,ttl ,col)
 533              ,@doc
 534              ,@decls
 535              (let ((,name (zone-make-name ,prefix ,zname)))
 536                (flet ((,list (&key ((:name ,tname) ,name)
 537                                    ((:type ,ttype) ,type)
 538                                    ((:data ,tdata) ,data)
 539                                    ((:ttl ,tttl) ,ttl)
 540                                    ((:make-ptr-p ,tmakeptrp) nil))
 541                         (collect (make-zone-record :name ,tname
 542                                                    :type ,ttype
 543                                                    :data ,tdata
 544                                                    :ttl ,tttl
 545                                                    :make-ptr-p ,tmakeptrp)
 546                                  ,col)))
 547                  ,@body)))
 548           ',type)))))
 549
 550 (defun zone-parse-records (zone records)
 551   (let ((zname (zone-name zone)))
 552     (with-collection (rec)
 553         (flet ((parse-record (zr)
 554                  (let ((func (or (get (zr-type zr) 'zone-parse)
 555                                  (error "No parser for record ~A."
 556                                         (zr-type zr))))
 557                        (name (and (zr-name zr) (stringify (zr-name zr)))))
 558                    (funcall func
 559                             name
 560                             zname
 561                             (zr-data zr)
 562                             (zr-ttl zr)
 563                             rec))))
 564           (zone-process-records records
 565                                 (zone-default-ttl zone)
 566                                 #'parse-record))
 567       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 568
 569 (defun zone-parse (zf)
 570   "Parse a ZONE form.  The syntax of a zone form is as follows:
 571
 572    ZONE-FORM:
 573      ZONE-HEAD ZONE-RECORD*
 574
 575    ZONE-RECORD:
 576      ((NAME*) ZONE-RECORD*)
 577    | SYM ARGS"
 578   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 579     (let ((zone (make-zone :name zname
 580                            :default-ttl ttl
 581                            :soa soa
 582                            :records nil)))
 583       (zone-parse-records zone (cdr zf))
 584       zone)))
 585
 586 (defun zone-create (zf)
 587   "Zone construction function.  Given a zone form ZF, construct the zone and
 588    add it to the table."
 589   (let* ((zone (zone-parse zf))
 590          (name (zone-name zone)))
 591     (setf (zone-find name) zone)
 592     name))
 593
 594 (defmacro defzone (soa &rest zf)
 595   "Zone definition macro."
 596   `(zone-create '(,soa ,@zf)))
 597
 598 (defmacro defrevzone (head &rest zf)
 599   "Define a reverse zone, with the correct name."
 600   (destructuring-bind
 601       (net &rest soa-args)
 602       (listify head)
 603     (let ((bytes nil))
 604       (when (and soa-args (integerp (car soa-args)))
 605         (setf bytes (pop soa-args)))
 606       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 607
 608 ;;;--------------------------------------------------------------------------
 609 ;;; Zone record parsers.
 610
 611 (defzoneparse :a (name data rec)
 612   ":a IPADDR"
 613   (rec :data (parse-ipaddr data) :make-ptr-p t))
 614
 615 (defzoneparse :svc (name data rec)
 616   ":svc IPADDR"
 617   (rec :type :a :data (parse-ipaddr data)))
 618
 619 (defzoneparse :ptr (name data rec :zname zname)
 620   ":ptr HOST"
 621   (rec :data (zone-parse-host data zname)))
 622
 623 (defzoneparse :cname (name data rec :zname zname)
 624   ":cname HOST"
 625   (rec :data (zone-parse-host data zname)))
 626
 627 (defzoneparse :mx (name data rec :zname zname)
 628   ":mx ((HOST :prio INT :ip IPADDR)*)"
 629   (dolist (mx (listify data))
 630     (destructuring-bind
 631         (mxname &key (prio *default-mx-priority*) ip)
 632         (listify mx)
 633       (let ((host (zone-parse-host mxname zname)))
 634         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 635         (rec :data (cons host prio))))))
 636
 637 (defzoneparse :ns (name data rec :zname zname)
 638   ":ns ((HOST :ip IPADDR)*)"
 639   (dolist (ns (listify data))
 640     (destructuring-bind
 641         (nsname &key ip)
 642         (listify ns)
 643       (let ((host (zone-parse-host nsname zname)))
 644         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 645         (rec :data host)))))
 646
 647 (defzoneparse :alias (name data rec :zname zname)
 648   ":alias (LABEL*)"
 649   (dolist (a (listify data))
 650     (rec :name (zone-parse-host a zname)
 651          :type :cname
 652          :data name)))
 653
 654 (defzoneparse :net (name data rec)
 655   ":net (NETWORK*)"
 656   (dolist (net (listify data))
 657     (let ((n (net-get-as-ipnet net)))
 658       (rec :name (zone-parse-host "net" name)
 659            :type :a
 660            :data (ipnet-net n))
 661       (rec :name (zone-parse-host "mask" name)
 662            :type :a
 663            :data (ipnet-mask n))
 664       (rec :name (zone-parse-host "broadcast" name)
 665            :type :a
 666            :data (ipnet-broadcast n)))))
 667
 668 (defzoneparse (:rev :reverse) (name data rec)
 669   ":reverse ((NET :bytes BYTES) ZONE*)"
 670   (setf data (listify data))
 671   (destructuring-bind
 672       (net &key bytes)
 673       (listify (car data))
 674     (setf net (zone-parse-net net name))
 675     (unless bytes
 676       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 677     (let ((seen (make-hash-table :test #'equal)))
 678       (dolist (z (or (cdr data)
 679                      (hash-table-keys *zones*)))
 680         (dolist (zr (zone-records (zone-find z)))
 681           (when (and (eq (zr-type zr) :a)
 682                      (zr-make-ptr-p zr)
 683                      (ipaddr-networkp (zr-data zr) net))
 684             (let ((name (string-downcase
 685                          (join-strings
 686                           #\.
 687                           (collecting ()
 688                             (dotimes (i bytes)
 689                               (collect (logand #xff (ash (zr-data zr)
 690                                                          (* -8 i)))))
 691                             (collect name))))))
 692               (unless (gethash name seen)
 693                 (rec :name name :type :ptr
 694                      :ttl (zr-ttl zr) :data (zr-name zr))
 695                 (setf (gethash name seen) t)))))))))
 696
 697 (defzoneparse (:cidr-delegation :cidr) (name data rec)
 698   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
 699   (destructuring-bind
 700       (net &key bytes)
 701       (listify (car data))
 702     (setf net (zone-parse-net net name))
 703     (unless bytes
 704       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 705     (dolist (map (cdr data))
 706       (destructuring-bind
 707           (tnet &optional tdom)
 708           (listify map)
 709         (setf tnet (zone-parse-net tnet name))
 710         (unless (ipnet-subnetp net tnet)
 711           (error "~A is not a subnet of ~A."
 712                  (ipnet-pretty tnet)
 713                  (ipnet-pretty net)))
 714         (unless tdom
 715           (with-ipnet (net mask) tnet
 716             (setf tdom
 717                   (join-strings
 718                    #\.
 719                    (append (reverse (loop
 720                                        for i from (1- bytes) downto 0
 721                                        until (zerop (logand mask
 722                                                             (ash #xff
 723                                                                  (* 8 i))))
 724                                        collect (logand #xff
 725                                                        (ash net (* -8 i)))))
 726                            (list name))))))
 727         (setf tdom (string-downcase tdom))
 728         (dotimes (i (ipnet-hosts tnet))
 729           (let* ((addr (ipnet-host tnet i))
 730                  (tail (join-strings #\.
 731                                      (loop
 732                                         for i from 0 below bytes
 733                                         collect
 734                                           (logand #xff
 735                                                   (ash addr (* 8 i)))))))
 736             (rec :name (format nil "~A.~A" tail name)
 737                  :type :cname
 738                  :data (format nil "~A.~A" tail tdom))))))))
 739
 740 ;;;--------------------------------------------------------------------------
 741 ;;; Zone file output.
 742
 743 (defgeneric zone-write (format zone stream)
 744   (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))
 745
 746 (defvar *writing-zone* nil
 747   "The zone currently being written.")
 748
 749 (defvar *zone-output-stream* nil
 750   "Stream to write zone data on.")
 751
 752 (defmethod zone-write :around (format zone stream)
 753   (let ((*writing-zone* zone)
 754         (*zone-output-stream* stream))
 755     (call-next-method)))
 756
 757 (defun zone-save (zones &key (format :bind))
 758   "Write the named ZONES to files.  If no zones are given, write all the
 759    zones."
 760   (unless zones
 761     (setf zones (hash-table-keys *zones*)))
 762   (safely (safe)
 763     (dolist (z zones)
 764       (let ((zz (zone-find z)))
 765         (unless zz
 766           (error "Unknown zone `~A'." z))
 767         (let ((stream (safely-open-output-stream safe
 768                                                  (zone-file-name z :zone))))
 769           (zone-write format zz stream))))))
 770
 771 ;;;--------------------------------------------------------------------------
 772 ;;; Bind format output.
 773
 774 (defun bind-hostname (hostname)
 775   (if (not hostname)
 776       "@"
 777       (let* ((h (string-downcase (stringify hostname)))
 778              (hl (length h))
 779              (r (string-downcase (zone-name *writing-zone*)))
 780              (rl (length r)))
 781         (cond ((string= r h) "@")
 782               ((and (> hl rl)
 783                     (char= (char h (- hl rl 1)) #\.)
 784                     (string= h r :start1 (- hl rl)))
 785                (subseq h 0 (- hl rl 1)))
 786               (t (concatenate 'string h "."))))))
 787
 788 (defmethod zone-write ((format (eql :bind)) zone stream)
 789   (format stream "~
 790 ;;; Zone file `~(~A~)'
 791 ;;;   (generated ~A)
 792
 793 $ORIGIN ~0@*~(~A.~)
 794 $TTL ~2@*~D~2%"
 795             (zone-name zone)
 796             (iso-date :now :datep t :timep t)
 797             (zone-default-ttl zone))
 798   (let* ((soa (zone-soa zone))
 799          (admin (let* ((name (soa-admin soa))
 800                        (at (position #\@ name))
 801                        (copy (format nil "~(~A~)." name)))
 802                   (when at
 803                     (setf (char copy at) #\.))
 804                   copy)))
 805       (format stream "~
 806 ~A~30TIN SOA~40T~A ~A (
 807 ~45T~10D~60T ;serial
 808 ~45T~10D~60T ;refresh
 809 ~45T~10D~60T ;retry
 810 ~45T~10D~60T ;expire
 811 ~45T~10D )~60T ;min-ttl~2%"
 812               (bind-hostname (zone-name zone))
 813               (bind-hostname (soa-source soa))
 814               admin
 815               (soa-serial soa)
 816               (soa-refresh soa)
 817               (soa-retry soa)
 818               (soa-expire soa)
 819               (soa-min-ttl soa)))
 820   (dolist (zr (zone-records zone))
 821     (bind-record (zr-type zr) zr)))
 822
 823 (defgeneric bind-record (type zr))
 824
 825 (defun bind-format-record (name ttl type format args)
 826   (format *zone-output-stream*
 827           "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
 828           (bind-hostname name)
 829           (and (/= ttl (zone-default-ttl *writing-zone*))
 830                ttl)
 831           (string-upcase (symbol-name type))
 832           format args))
 833
 834 (defmethod bind-record (type zr)
 835   (destructuring-bind (format &rest args)
 836       (bind-record-format-args type (zr-data zr))
 837     (bind-format-record (zr-name zr)
 838                         (zr-ttl zr)
 839                         (bind-record-type type)
 840                         format args)))
 841
 842 (defgeneric bind-record-type (type)
 843   (:method (type) type))
 844
 845 (defgeneric bind-record-format-args (type data)
 846   (:method ((type (eql :a)) data) (list "~A" (ipaddr-string data)))
 847   (:method ((type (eql :ptr)) data) (list "~A" (bind-hostname data)))
 848   (:method ((type (eql :cname)) data) (list "~A" (bind-hostname data)))
 849   (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data)))
 850   (:method ((type (eql :mx)) data)
 851     (list "~2D ~A" (cdr data) (bind-hostname (car data))))
 852   (:method ((type (eql :txt)) data) (list "~S" (stringify data))))
 853
 854 ;;;----- That's all, folks --------------------------------------------------