chiark - git - mdw - zone/blob - zone.lisp

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