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