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