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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; DNS zone generation
   6 ;;;
   7 ;;; (c) 2005 Straylight/Edgeware
   8 ;;;
   9
  10 ;;;----- Licensing notice ---------------------------------------------------
  11 ;;;
  12 ;;; This program is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; This program is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with this program; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 ;;;--------------------------------------------------------------------------
  27 ;;; Packaging.
  28
  29 (defpackage #:zone
  30   (:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #:safely)
  31   (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp
  32            #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet
  33              #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet
  34              #:ipnet-pretty #:ipnet-string #:ipnet-broadcast #:ipnet-hosts
  35              #:ipnet-host #:ipaddr-networkp #:ipnet-subnetp
  36            #:host-find# #:host-create #:defhost #:parse-ipaddr
  37              #:net #:net-find #:net-get-as-ipnet #:net-create #:defnet
  38              #:net-next-host #:net-host
  39            #:soa #:mx #:zone #:zone-record #:zone-subdomain
  40            #:*default-zone-source* #:*default-zone-refresh*
  41              #:*default-zone-retry* #:*default-zone-expire*
  42              #:*default-zone-min-ttl* #:*default-zone-ttl*
  43              #:*default-mx-priority* #:*default-zone-admin*
  44              #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
  45              #:defrevzone #:zone-save
  46            #:defzoneparse #:zone-parse-host
  47            #:timespec-seconds #:make-zone-serial))
  48
  49 (in-package #:zone)
  50
  51 ;;;--------------------------------------------------------------------------
  52 ;;; Basic types.
  53
  54 (defun mask (n)
  55   "Return 2^N - 1: i.e., a mask of N set bits."
  56   (1- (ash 1 n)))
  57 (deftype u32 ()
  58   "The type of unsigned 32-bit values."
  59   '(unsigned-byte 32))
  60 (deftype ipaddr ()
  61   "The type of IP (version 4) addresses."
  62   'u32)
  63
  64 ;;;--------------------------------------------------------------------------
  65 ;;; Various random utilities.
  66
  67 (defun to-integer (x)
  68   "Convert X to an integer in the most straightforward way."
  69   (floor (rational x)))
  70
  71 (defun from-mixed-base (base val)
  72   "BASE is a list of the ranges for the `digits' of a mixed-base
  73 representation.  Convert VAL, a list of digits, into an integer."
  74   (do ((base base (cdr base))
  75        (val (cdr val) (cdr val))
  76        (a (car val) (+ (* a (car base)) (car val))))
  77       ((or (null base) (null val)) a)))
  78
  79 (defun to-mixed-base (base val)
  80   "BASE is a list of the ranges for the `digits' of a mixed-base
  81 representation.  Convert VAL, an integer, into a list of digits."
  82   (let ((base (reverse base))
  83         (a nil))
  84     (loop
  85       (unless base
  86         (push val a)
  87         (return a))
  88       (multiple-value-bind (q r) (floor val (pop base))
  89         (push r a)
  90         (setf val q)))))
  91
  92 (defun timespec-seconds (ts)
  93   "Convert a timespec TS to seconds.  A timespec may be a real count of
  94 seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious time
  95 units."
  96   (cond ((null ts) 0)
  97         ((realp ts) (floor ts))
  98         ((atom ts)
  99          (error "Unknown timespec format ~A" ts))
 100         ((null (cdr ts))
 101          (timespec-seconds (car ts)))
 102         (t (+ (to-integer (* (car ts)
 103                              (case (intern (string-upcase
 104                                             (stringify (cadr ts)))
 105                                            '#:zone)
 106                                ((s sec secs second seconds) 1)
 107                                ((m min mins minute minutes) 60)
 108                                ((h hr hrs hour hours) #.(* 60 60))
 109                                ((d dy dys day days) #.(* 24 60 60))
 110                                ((w wk wks week weeks) #.(* 7 24 60 60))
 111                                ((y yr yrs year years) #.(* 365 24 60 60))
 112                                (t (error "Unknown time unit ~A"
 113                                          (cadr ts))))))
 114               (timespec-seconds (cddr ts))))))
 115
 116 (defun hash-table-keys (ht)
 117   "Return a list of the keys in hashtable HT."
 118   (collecting ()
 119     (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
 120
 121 (defun iso-date (&optional time &key datep timep (sep #\ ))
 122   "Construct a textual date or time in ISO format.  The TIME is the universal
 123 time to convert, which defaults to now; DATEP is whether to emit the date;
 124 TIMEP is whether to emit the time, and SEP (default is space) is how to
 125 separate the two."
 126   (multiple-value-bind
 127       (sec min hr day mon yr dow dstp tz)
 128       (decode-universal-time (if (or (null time) (eq time :now))
 129                                  (get-universal-time)
 130                                  time))
 131     (declare (ignore dow dstp tz))
 132     (with-output-to-string (s)
 133       (when datep
 134         (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
 135         (when timep
 136           (write-char sep s)))
 137       (when timep
 138         (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 139
 140 (defun count-low-zero-bits (n)
 141   "Return the number of low-order zero bits in the integer N."
 142   (if (zerop n) nil
 143       (loop for i from 0
 144             until (logbitp i n)
 145             finally (return i))))
 146
 147 ;;;--------------------------------------------------------------------------
 148 ;;; Simple messing with IP addresses.
 149
 150 (defun string-ipaddr (str &key (start 0) (end nil))
 151   "Parse STR as an IP address in dotted-quad form and return the integer
 152 equivalent.  STR may be anything at all: it's converted as if by
 153 `stringify'.  The START and END arguments may be used to parse out a
 154 substring."
 155   (setf str (stringify str))
 156   (unless end
 157     (setf end (length str)))
 158   (let ((addr 0) (noct 0))
 159     (loop
 160       (let* ((pos (position #\. str :start start :end end))
 161              (i (parse-integer str :start start :end (or pos end))))
 162         (unless (<= 0 i 256)
 163           (error "IP address octet out of range"))
 164         (setf addr (+ (* addr 256) i))
 165         (incf noct)
 166         (unless pos
 167           (return))
 168         (setf start (1+ pos))))
 169     (unless (= noct 4)
 170       (error "Wrong number of octets in IP address"))
 171     addr))
 172
 173 (defun ipaddr-byte (ip n)
 174   "Return byte N (from most significant downwards) of an IP address."
 175   (assert (<= 0 n 3))
 176   (logand #xff (ash ip (* -8 (- 3 n)))))
 177
 178 (defun ipaddr-string (ip)
 179   "Transform the address IP into a string in dotted-quad form."
 180   (check-type ip ipaddr)
 181   (join-strings #\. (collecting ()
 182                       (dotimes (i 4)
 183                         (collect (ipaddr-byte ip i))))))
 184
 185 (defun ipaddrp (ip)
 186   "Answer true if IP is a valid IP address in integer form."
 187   (typep ip 'ipaddr))
 188
 189 (defun ipaddr (ip)
 190   "Convert IP to an IP address.  If it's an integer, return it unchanged;
 191 otherwise convert by `string-ipaddr'."
 192   (typecase ip
 193     (ipaddr ip)
 194     (t (string-ipaddr ip))))
 195
 196 ;;;--------------------------------------------------------------------------
 197 ;;; Netmasks.
 198
 199 (defun integer-netmask (i)
 200   "Given an integer I, return a netmask with its I top bits set."
 201   (- (ash 1 32) (ash 1 (- 32 i))))
 202
 203 (defun ipmask (ip)
 204   "Transform IP into a netmask.  If it's a small integer then it's converted
 205 by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
 206 `ipaddr'."
 207   (typecase ip
 208     (null (mask 32))
 209     ((integer 0 32) (integer-netmask ip))
 210     (t (ipaddr ip))))
 211
 212 (defun ipmask-cidl-slash (mask)
 213   "Given a netmask MASK, return an integer N such that (integer-netmask N) =
 214 MASK, or nil if this is impossible."
 215   (dotimes (i 33)
 216     (when (= mask (integer-netmask i))
 217       (return i))))
 218
 219 ;;;--------------------------------------------------------------------------
 220 ;;; Networks: pairing an address and netmask.
 221
 222 (defun make-ipnet (net mask)
 223   "Construct an IP-network object given the NET and MASK; these are
 224 transformed as though by `ipaddr' and `ipmask'."
 225   (let ((net (ipaddr net))
 226         (mask (ipmask mask)))
 227     (cons (logand net mask) mask)))
 228
 229 (defun string-ipnet (str &key (start 0) (end nil))
 230   "Parse an IP-network from the string STR."
 231   (setf str (stringify str))
 232   (unless end (setf end (length str)))
 233   (let ((sl (position #\/ str :start start :end end)))
 234     (if sl
 235         (make-ipnet (parse-ipaddr (subseq str start sl))
 236                     (if (find #\. str :start (1+ sl) :end end)
 237                         (string-ipaddr str :start (1+ sl) :end end)
 238                         (integer-netmask (parse-integer str
 239                                                         :start (1+ sl)
 240                                                         :end end))))
 241         (make-ipnet (parse-ipaddr (subseq str start end))
 242                     (integer-netmask 32)))))
 243
 244 (defun ipnet (net)
 245   "Construct an IP-network object from the given argument.  A number of
 246 forms are acceptable:
 247
 248   * ADDR -- a single address (equivalent to ADDR 32)
 249   * (NET . MASK|nil) -- a single-object representation.
 250   * IPNET -- return an equivalent (`equal', not necessarily `eql') version."
 251   (cond ((or (stringp net) (symbolp net)) (string-ipnet net))
 252         (t (apply #'make-ipnet (pairify net 32)))))
 253
 254 (defun ipnet-net (ipn)
 255   "Return the base network address of IPN."
 256   (car ipn))
 257
 258 (defun ipnet-mask (ipn)
 259   "Return the netmask of IPN."
 260   (cdr ipn))
 261
 262 (defmacro with-ipnet ((net mask) ipn &body body)
 263   "Evaluate BODY with NET and MASK bound to the base address and netmask of
 264 IPN.  Either NET or MASK (or, less usefully, both) may be nil if not wanted."
 265   (with-gensyms tmp
 266     `(let ((,tmp ,ipn))
 267        (let (,@(and net `((,net (ipnet-net ,tmp))))
 268              ,@(and mask `((,mask (ipnet-mask ,tmp)))))
 269          ,@body))))
 270
 271 (defun ipnet-pretty (ipn)
 272   "Convert IPN to a pretty cons-cell form."
 273   (with-ipnet (net mask) ipn
 274     (cons (ipaddr-string net)
 275           (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
 276
 277 (defun ipnet-string (ipn)
 278   "Convert IPN to a string."
 279   (with-ipnet (net mask) ipn
 280     (format nil "~A/~A"
 281             (ipaddr-string net)
 282             (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
 283
 284 (defun ipnet-broadcast (ipn)
 285   "Return the broadcast address for the network IPN."
 286   (with-ipnet (net mask) ipn
 287     (logior net (logxor (mask 32) mask))))
 288
 289 (defun ipnet-hosts (ipn)
 290   "Return the number of available addresses in network IPN."
 291   (ash 1 (- 32 (logcount (ipnet-mask ipn)))))
 292
 293 (defun ipnet-host (ipn host)
 294   "Return the address of the given HOST in network IPN.  This works even with
 295 a non-contiguous netmask."
 296   (check-type host u32)
 297   (with-ipnet (net mask) ipn
 298     (let ((i 0) (m 1) (a net) (h host))
 299       (loop
 300         (when (>= i 32)
 301           (error "Host index ~D out of range for network ~A"
 302                  host (ipnet-pretty ipn)))
 303         (cond ((zerop h)
 304                (return a))
 305               ((logbitp i mask)
 306                (setf h (ash h 1)))
 307               (t
 308                (setf a (logior a (logand m h)))
 309                (setf h (logandc2 h m))))
 310         (setf m (ash m 1))
 311         (incf i)))))
 312
 313 (defun ipaddr-networkp (ip ipn)
 314   "Returns true if address IP is within network IPN."
 315   (with-ipnet (net mask) ipn
 316     (= net (logand ip mask))))
 317
 318 (defun ipnet-subnetp (ipn subn)
 319   "Returns true if SUBN is a (non-strict) subnet of IPN."
 320   (with-ipnet (net mask) ipn
 321     (with-ipnet (subnet submask) subn
 322       (and (= net (logand subnet mask))
 323            (= submask (logior mask submask))))))
 324
 325 (defun ipnet-changeable-bytes (mask)
 326   "Answers how many low-order bytes of MASK are (entirely or partially)
 327 changeable.  This is used when constructing reverse zones."
 328   (dotimes (i 4 4)
 329     (when (/= (ipaddr-byte mask i) 255)
 330       (return (- 4 i)))))
 331
 332 ;;;--------------------------------------------------------------------------
 333 ;;; Name resolution.
 334
 335 #+cmu
 336 (defun resolve-hostname (name)
 337   "Resolve a hostname to an IP address using the DNS, or return nil."
 338   (let ((he (ext:lookup-host-entry name)))
 339     (and he
 340          (ext:host-entry-addr he))))
 341
 342 #+cmu
 343 (defun canonify-hostname (name)
 344   "Resolve a hostname to canonical form using the DNS, or return nil."
 345   (let ((he (ext:lookup-host-entry name)))
 346     (and he
 347          (ext:host-entry-name he))))
 348
 349 ;;;--------------------------------------------------------------------------
 350 ;;; Host names and specifiers.
 351
 352 (defun parse-ipaddr (addr)
 353   "Convert the string ADDR into an IP address: tries all sorts of things:
 354
 355   (NET [INDEX]) -- index a network: NET is a network name defined by defnet;
 356     INDEX is an index or one of the special symbols understood by net-host,
 357     and defaults to :next
 358   INTEGER -- an integer IP address
 359   IPADDR -- an IP address in dotted-quad form
 360   HOST -- a host name defined by defhost
 361   DNSNAME -- a name string to look up in the DNS"
 362   (cond ((listp addr)
 363          (destructuring-bind
 364              (net host)
 365              (pairify addr :next)
 366            (net-host (or (net-find net)
 367                          (error "Network ~A not found" net))
 368                      host)))
 369         ((ipaddrp addr) addr)
 370         (t
 371          (setf addr (string-downcase (stringify addr)))
 372          (or (host-find addr)
 373              (and (plusp (length addr))
 374                   (digit-char-p (char addr 0))
 375                   (string-ipaddr addr))
 376              (resolve-hostname (stringify addr))
 377              (error "Host name ~A unresolvable" addr)))))
 378
 379 (defvar *hosts* (make-hash-table :test #'equal)
 380   "The table of known hostnames.")
 381
 382 (defun host-find (name)
 383   "Find a host by NAME."
 384   (gethash (string-downcase (stringify name)) *hosts*))
 385
 386 (defun (setf host-find) (addr name)
 387   "Make NAME map to ADDR (must be an ipaddr in integer form)."
 388   (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
 389
 390 (defun host-create (name addr)
 391   "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
 392   (setf (host-find name) (parse-ipaddr addr)))
 393
 394 (defmacro defhost (name addr)
 395   "Main host definition macro.  Neither NAME nor ADDR is evaluated."
 396   `(progn
 397      (host-create ',name ',addr)
 398      ',name))
 399
 400 ;;;--------------------------------------------------------------------------
 401 ;;; Network names and specifiers.
 402
 403 (defstruct (net (:predicate netp))
 404   "A network structure.  Slots:
 405
 406 NAME       The network's name, as a string
 407 IPNET      The network base address and mask
 408 HOSTS      Number of hosts in the network
 409 NEXT       Index of the next unassigned host"
 410   name
 411   ipnet
 412   hosts
 413   next)
 414
 415 (defvar *networks* (make-hash-table :test #'equal)
 416   "The table of known networks.")
 417
 418 (defun net-find (name)
 419   "Find a network by NAME."
 420   (gethash (string-downcase (stringify name)) *networks*))
 421
 422 (defun (setf net-find) (net name)
 423   "Make NAME map to NET."
 424   (setf (gethash (string-downcase (stringify name)) *networks*) net))
 425
 426 (defun net-get-as-ipnet (form)
 427   "Transform FORM into an ipnet.  FORM may be a network name, or something
 428 acceptable to the ipnet function."
 429   (let ((net (net-find form)))
 430     (if net (net-ipnet net)
 431         (ipnet form))))
 432
 433 (defun process-net-form (root addr subnets)
 434   "Unpack a net-form.  The return value is a list of entries, each of which
 435 is a list of the form (NAME ADDR MASK).  The first entry is merely repeats
 436 the given ROOT and ADDR arguments (unpacking ADDR into separate network
 437 address and mask).  The SUBNETS are then processed: they are a list of items
 438 of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet,
 439 NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in
 440 the same form.  An error is signalled if a net's subnets use up more hosts
 441 than the net has to start with."
 442   (labels ((frob (subnets limit finger)
 443              (when subnets
 444                (destructuring-bind (name size &rest subs) (car subnets)
 445                  (when (> (count-low-zero-bits size)
 446                           (count-low-zero-bits finger))
 447                    (error "Bad subnet size for ~A." name))
 448                  (when (> (+ finger size) limit)
 449                    (error "Subnet ~A out of range." name))
 450                  (append (and name
 451                               (list (list name finger (- (ash 1 32) size))))
 452                          (frob subs (+ finger size) finger)
 453                          (frob (cdr subnets) limit (+ finger size)))))))
 454     (let ((ipn (ipnet addr)))
 455       (with-ipnet (net mask) ipn
 456         (unless (ipmask-cidl-slash mask)
 457           (error "Bad mask for subnet form."))
 458         (cons (list root net mask)
 459               (frob subnets (+ net (ipnet-hosts ipn) 1) net))))))
 460
 461 (defun net-create (name net)
 462   "Construct a new network called NAME and add it to the map.  The ARGS
 463 describe the new network, in a form acceptable to the ipnet function."
 464   (let ((ipn (ipnet net)))
 465     (setf (net-find name)
 466           (make-net :name (string-downcase (stringify name))
 467                     :ipnet ipn
 468                     :hosts (ipnet-hosts ipn)
 469                     :next 1))))
 470
 471 (defmacro defnet (name net &rest subnets)
 472   "Main network definition macro.  None of the arguments is evaluated."
 473   `(progn
 474     ,@(loop for (name addr mask) in (process-net-form name net subnets)
 475             collect `(net-create ',name '(,addr . ,mask)))
 476     ',name))
 477
 478 (defun net-next-host (net)
 479   "Given a NET, return the IP address (as integer) of the next available
 480 address in the network."
 481   (unless (< (net-next net) (net-hosts net))
 482     (error "No more hosts left in network ~A" (net-name net)))
 483   (let ((next (net-next net)))
 484     (incf (net-next net))
 485     (net-host net next)))
 486
 487 (defun net-host (net host)
 488   "Return the given HOST on the NEXT.  HOST may be an index (in range, of
 489 course), or one of the keywords:
 490 :NEXT       next host, as by net-next-host
 491 :NET        network base address
 492 :BROADCAST  network broadcast address"
 493   (case host
 494     (:next (net-next-host net))
 495     (:net (ipnet-net (net-ipnet net)))
 496     (:broadcast (ipnet-broadcast (net-ipnet net)))
 497     (t (ipnet-host (net-ipnet net) host))))
 498
 499 ;;;--------------------------------------------------------------------------
 500 ;;; Zone types.
 501
 502 (defstruct (soa (:predicate soap))
 503   "Start-of-authority record information."
 504   source
 505   admin
 506   refresh
 507   retry
 508   expire
 509   min-ttl
 510   serial)
 511
 512 (defstruct (mx (:predicate mxp))
 513   "Mail-exchange record information."
 514   priority
 515   domain)
 516
 517 (defstruct (zone (:predicate zonep))
 518   "Zone information."
 519   soa
 520   default-ttl
 521   name
 522   records)
 523
 524 ;;;--------------------------------------------------------------------------
 525 ;;; Zone defaults.  It is intended that scripts override these.
 526
 527 (defvar *default-zone-source*
 528   (let ((hn (unix:unix-gethostname)))
 529     (and hn (concatenate 'string (canonify-hostname hn) ".")))
 530   "The default zone source: the current host's name.")
 531
 532 (defvar *default-zone-refresh* (* 24 60 60)
 533   "Default zone refresh interval: one day.")
 534
 535 (defvar *default-zone-admin* nil
 536   "Default zone administrator's email address.")
 537
 538 (defvar *default-zone-retry* (* 60 60)
 539   "Default znoe retry interval: one hour.")
 540
 541 (defvar *default-zone-expire* (* 14 24 60 60)
 542   "Default zone expiry time: two weeks.")
 543
 544 (defvar *default-zone-min-ttl* (* 4 60 60)
 545   "Default zone minimum TTL/negative TTL: four hours.")
 546
 547 (defvar *default-zone-ttl* (* 8 60 60)
 548   "Default zone TTL (for records without explicit TTLs): 8 hours.")
 549
 550 (defvar *default-mx-priority* 50
 551   "Default MX priority.")
 552
 553 ;;;--------------------------------------------------------------------------
 554 ;;; Serial numbering.
 555
 556 (defun make-zone-serial (name)
 557   "Given a zone NAME, come up with a new serial number.  This will (very
 558 carefully) update a file ZONE.serial in the current directory."
 559   (let* ((file (format nil "~(~A~).serial" name))
 560          (last (with-open-file (in file
 561                                    :direction :input
 562                                    :if-does-not-exist nil)
 563                  (if in (read in)
 564                      (list 0 0 0 0))))
 565          (now (multiple-value-bind
 566                   (sec min hr dy mon yr dow dstp tz)
 567                   (get-decoded-time)
 568                 (declare (ignore sec min hr dow dstp tz))
 569                 (list dy mon yr)))
 570          (seq (cond ((not (equal now (cdr last))) 0)
 571                     ((< (car last) 99) (1+ (car last)))
 572                     (t (error "Run out of sequence numbers for ~A" name)))))
 573     (safely-writing (out file)
 574       (format out
 575               ";; Serial number file for zone ~A~%~
 576                ;;   (LAST-SEQ DAY MONTH YEAR)~%~
 577                ~S~%"
 578               name
 579               (cons seq now)))
 580     (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
 581
 582 ;;;--------------------------------------------------------------------------
 583 ;;; Zone variables and structures.
 584
 585 (defvar *zones* (make-hash-table :test #'equal)
 586   "Map of known zones.")
 587
 588 (defun zone-find (name)
 589   "Find a zone given its NAME."
 590   (gethash (string-downcase (stringify name)) *zones*))
 591
 592 (defun (setf zone-find) (zone name)
 593   "Make the zone NAME map to ZONE."
 594   (setf (gethash (string-downcase (stringify name)) *zones*) zone))
 595
 596 (defstruct (zone-record (:conc-name zr-))
 597   "A zone record."
 598   (name '<unnamed>)
 599   ttl
 600   type
 601   (defsubp nil)
 602   data)
 603
 604 (defstruct (zone-subdomain (:conc-name zs-))
 605   "A subdomain.  Slightly weird.  Used internally by zone-process-records
 606 below, and shouldn't escape."
 607   name
 608   ttl
 609   records)
 610
 611 ;;;--------------------------------------------------------------------------
 612 ;;; Zone infrastructure.
 613
 614 (defun zone-process-records (rec ttl func)
 615   "Sort out the list of records in REC, calling FUNC for each one.  TTL is
 616 the default time-to-live for records which don't specify one."
 617   (labels ((sift (rec ttl)
 618              (collecting (top sub)
 619                (loop
 620                  (unless rec
 621                    (return))
 622                  (let ((r (pop rec)))
 623                    (cond ((eq r :ttl)
 624                           (setf ttl (pop rec)))
 625                          ((symbolp r)
 626                           (collect (make-zone-record :type r
 627                                                      :ttl ttl
 628                                                      :data (pop rec))
 629                                    top))
 630                          ((listp r)
 631                           (dolist (name (listify (car r)))
 632                             (collect (make-zone-subdomain :name name
 633                                                           :ttl ttl
 634                                                           :records (cdr r))
 635                                      sub)))
 636                          (t
 637                           (error "Unexpected record form ~A" (car r))))))))
 638            (process (rec dom ttl defsubp)
 639              (multiple-value-bind (top sub) (sift rec ttl)
 640                (if (and dom (null top) sub)
 641                    (let ((s (pop sub)))
 642                      (process (zs-records s)
 643                               dom
 644                               (zs-ttl s)
 645                               defsubp)
 646                      (process (zs-records s)
 647                               (cons (zs-name s) dom)
 648                               (zs-ttl s)
 649                               t))
 650                  (let ((name (and dom
 651                                   (string-downcase
 652                                    (join-strings #\. (reverse dom))))))
 653                    (dolist (zr top)
 654                      (setf (zr-name zr) name)
 655                      (setf (zr-defsubp zr) defsubp)
 656                      (funcall func zr))))
 657                (dolist (s sub)
 658                  (process (zs-records s)
 659                           (cons (zs-name s) dom)
 660                           (zs-ttl s)
 661                           defsubp)))))
 662     (process rec nil ttl nil)))
 663
 664 (defun zone-parse-host (f zname)
 665   "Parse a host name F: if F ends in a dot then it's considered absolute;
 666 otherwise it's relative to ZNAME."
 667   (setf f (stringify f))
 668   (cond ((string= f "@") (stringify zname))
 669         ((and (plusp (length f))
 670               (char= (char f (1- (length f))) #\.))
 671          (string-downcase (subseq f 0 (1- (length f)))))
 672         (t (string-downcase (concatenate 'string f "."
 673                                          (stringify zname))))))
 674 (defun default-rev-zone (base bytes)
 675   "Return the default reverse-zone name for the given BASE address and number
 676 of fixed leading BYTES."
 677   (join-strings #\. (collecting ()
 678                       (loop for i from (- 3 bytes) downto 0
 679                             do (collect (ipaddr-byte base i)))
 680                       (collect "in-addr.arpa"))))
 681
 682 (defun zone-name-from-net (net &optional bytes)
 683   "Given a NET, and maybe the BYTES to use, convert to the appropriate
 684 subdomain of in-addr.arpa."
 685   (let ((ipn (net-get-as-ipnet net)))
 686     (with-ipnet (net mask) ipn
 687       (unless bytes
 688         (setf bytes (- 4 (ipnet-changeable-bytes mask))))
 689       (join-strings #\.
 690                     (append (loop
 691                                for i from (- 4 bytes) below 4
 692                                collect (logand #xff (ash net (* -8 i))))
 693                             (list "in-addr.arpa"))))))
 694
 695 (defun zone-net-from-name (name)
 696   "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
 697   (let* ((name (string-downcase (stringify name)))
 698          (len (length name))
 699          (suffix ".in-addr.arpa")
 700          (sufflen (length suffix))
 701          (addr 0)
 702          (n 0)
 703          (end (- len sufflen)))
 704     (unless (and (> len sufflen)
 705                  (string= name suffix :start1 end))
 706       (error "`~A' not in ~A." name suffix))
 707     (loop
 708        with start = 0
 709        for dot = (position #\. name :start start :end end)
 710        for byte = (parse-integer name
 711                                  :start start
 712                                  :end (or dot end))
 713        do (setf addr (logior addr (ash byte (* 8 n))))
 714           (incf n)
 715        when (>= n 4)
 716        do (error "Can't deduce network from ~A." name)
 717        while dot
 718        do (setf start (1+ dot)))
 719     (setf addr (ash addr (* 8 (- 4 n))))
 720     (make-ipnet addr (* 8 n))))
 721
 722 (defun zone-reverse-records (records net list bytes dom)
 723   "Construct a reverse zone given a forward zone's RECORDS list, the NET that
 724 the reverse zone is to serve, a LIST to collect the records into, how
 725 many BYTES of data need to end up in the zone, and the DOM-ain suffix."
 726   (dolist (zr records)
 727     (when (and (eq (zr-type zr) :a)
 728                (not (zr-defsubp zr))
 729                (ipaddr-networkp (zr-data zr) net))
 730       (collect (make-zone-record
 731                 :name (string-downcase
 732                        (join-strings
 733                         #\.
 734                         (collecting ()
 735                           (dotimes (i bytes)
 736                             (collect (logand #xff (ash (zr-data zr)
 737                                                        (* -8 i)))))
 738                           (collect dom))))
 739                 :type :ptr
 740                 :ttl (zr-ttl zr)
 741                 :data (zr-name zr))
 742                list))))
 743
 744 (defun zone-reverse (data name list)
 745   "Process a :reverse record's DATA, for a domain called NAME, and add the
 746 records to the LIST."
 747   (destructuring-bind
 748       (net &key bytes zones)
 749       (listify data)
 750     (setf net (zone-parse-net net name))
 751     (dolist (z (or (listify zones)
 752                    (hash-table-keys *zones*)))
 753       (zone-reverse-records (zone-records (zone-find z))
 754                             net
 755                             list
 756                             (or bytes
 757                                 (ipnet-changeable-bytes (ipnet-mask net)))
 758                             name))))
 759
 760 (defun zone-parse-net (net name)
 761   "Given a NET, and the NAME of a domain to guess from if NET is null,
 762 return the ipnet for the network."
 763   (if net
 764       (net-get-as-ipnet net)
 765       (zone-net-from-name name)))
 766
 767 (defun zone-cidr-delg-default-name (ipn bytes)
 768   "Given a delegated net IPN and the parent's number of changing BYTES,
 769 return the default deletate zone prefix."
 770   (with-ipnet (net mask) ipn
 771     (join-strings #\.
 772                   (reverse
 773                    (loop
 774                       for i from (1- bytes) downto 0
 775                       until (zerop (logand mask (ash #xff (* 8 i))))
 776                       collect (logand #xff (ash net (* -8 i))))))))
 777
 778 (defun zone-cidr-delegation (data name ttl list)
 779   "Given :cidr-delegation info DATA, for a record called NAME and the current
 780 TTL, write lots of CNAME records to LIST."
 781   (destructuring-bind
 782       (net &key bytes)
 783       (listify (car data))
 784     (setf net (zone-parse-net net name))
 785     (unless bytes
 786       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
 787     (dolist (map (cdr data))
 788       (destructuring-bind
 789           (tnet &optional tdom)
 790           (listify map)
 791         (setf tnet (zone-parse-net tnet name))
 792         (unless (ipnet-subnetp net tnet)
 793           (error "~A is not a subnet of ~A."
 794                  (ipnet-pretty tnet)
 795                  (ipnet-pretty net)))
 796         (unless tdom
 797           (setf tdom
 798                 (join-strings #\.
 799                               (list (zone-cidr-delg-default-name tnet bytes)
 800                                     name))))
 801         (setf tdom (string-downcase tdom))
 802         (dotimes (i (ipnet-hosts tnet))
 803           (let* ((addr (ipnet-host tnet i))
 804                  (tail (join-strings #\.
 805                                      (loop
 806                                         for i from 0 below bytes
 807                                         collect
 808                                           (logand #xff
 809                                                   (ash addr (* 8 i)))))))
 810             (collect (make-zone-record
 811                       :name (join-strings #\.
 812                                           (list tail name))
 813                       :type :cname
 814                       :ttl ttl
 815                       :data (join-strings #\. (list tail tdom)))
 816                      list)))))))
 817
 818 ;;;--------------------------------------------------------------------------
 819 ;;; Zone form parsing.
 820
 821 (defun zone-parse-head (head)
 822   "Parse the HEAD of a zone form.  This has the form
 823
 824      (NAME &key :source :admin :refresh :retry
 825                 :expire :min-ttl :ttl :serial)
 826
 827 though a singleton NAME needn't be a list.  Returns the default TTL and an
 828 soa structure representing the zone head."
 829   (destructuring-bind
 830       (zname
 831        &key
 832        (source *default-zone-source*)
 833        (admin (or *default-zone-admin*
 834                   (format nil "hostmaster@~A" zname)))
 835        (refresh *default-zone-refresh*)
 836        (retry *default-zone-retry*)
 837        (expire *default-zone-expire*)
 838        (min-ttl *default-zone-min-ttl*)
 839        (ttl min-ttl)
 840        (serial (make-zone-serial zname)))
 841       (listify head)
 842     (values zname
 843             (timespec-seconds ttl)
 844             (make-soa :admin admin
 845                       :source (zone-parse-host source zname)
 846                       :refresh (timespec-seconds refresh)
 847                       :retry (timespec-seconds retry)
 848                       :expire (timespec-seconds expire)
 849                       :min-ttl (timespec-seconds min-ttl)
 850                       :serial serial))))
 851
 852 (defmacro defzoneparse (types (name data list
 853                                &key (zname (gensym "ZNAME"))
 854                                     (ttl (gensym "TTL"))
 855                                     (defsubp (gensym "DEFSUBP")))
 856                         &body body)
 857   "Define a new zone record type (or TYPES -- a list of synonyms is
 858 permitted).  The arguments are as follows:
 859
 860 NAME    The name of the record to be added.
 861
 862 DATA    The content of the record to be added (a single object, unevaluated).
 863
 864 LIST    A function to add a record to the zone.  See below.
 865
 866 ZNAME   The name of the zone being constructed.
 867
 868 TTL     The TTL for this record.
 869
 870 DEFSUBP Whether this is the default subdomain for this entry.
 871
 872 You get to choose your own names for these.  ZNAME, TTL and DEFSUBP are
 873 optional: you don't have to accept them if you're not interested.
 874
 875 The LIST argument names a function to be bound in the body to add a new
 876 low-level record to the zone.  It has the prototype
 877
 878   (LIST &key :name :type :data :ttl :defsubp)
 879
 880 Except for defsubp, these default to the above arguments (even if you didn't
 881 accept the arguments)."
 882   (setf types (listify types))
 883   (let* ((type (car types))
 884          (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
 885     (with-gensyms (col tname ttype tttl tdata tdefsubp i)
 886       `(progn
 887          (dolist (,i ',types)
 888            (setf (get ,i 'zone-parse) ',func))
 889          (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
 890            (declare (ignorable ,zname ,defsubp))
 891            (flet ((,list (&key ((:name ,tname) ,name)
 892                                ((:type ,ttype) ,type)
 893                                ((:data ,tdata) ,data)
 894                                ((:ttl ,tttl) ,ttl)
 895                                ((:defsubp ,tdefsubp) nil))
 896                     (collect (make-zone-record :name ,tname
 897                                                :type ,ttype
 898                                                :data ,tdata
 899                                                :ttl ,tttl
 900                                                :defsubp ,tdefsubp)
 901                              ,col)))
 902              ,@body))
 903          ',type))))
 904
 905 (defun zone-parse-records (zone records)
 906   (let ((zname (zone-name zone)))
 907     (with-collection (rec)
 908         (flet ((parse-record (zr)
 909                  (let ((func (or (get (zr-type zr) 'zone-parse)
 910                                  (error "No parser for record ~A."
 911                                         (zr-type zr))))
 912                        (name (and (zr-name zr)
 913                                   (stringify (zr-name zr)))))
 914                    (if (or (not name)
 915                            (string= name "@"))
 916                        (setf name zname)
 917                        (let ((len (length name)))
 918                          (if (or (zerop len)
 919                                  (char/= (char name (1- len)) #\.))
 920                              (setf name (join-strings #\.
 921                                                       (list name zname))))))
 922                    (funcall func
 923                             name
 924                             (zr-data zr)
 925                             (zr-ttl zr)
 926                             rec
 927                             zname
 928                             (zr-defsubp zr)))))
 929           (zone-process-records records
 930                                 (zone-default-ttl zone)
 931                                 #'parse-record ))
 932       (setf (zone-records zone) (nconc (zone-records zone) rec)))))
 933
 934 (defun zone-parse (zf)
 935   "Parse a ZONE form.  The syntax of a zone form is as follows:
 936
 937 ZONE-FORM:
 938   ZONE-HEAD ZONE-RECORD*
 939
 940 ZONE-RECORD:
 941   ((NAME*) ZONE-RECORD*)
 942 | SYM ARGS"
 943   (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
 944     (let ((zone (make-zone :name zname
 945                            :default-ttl ttl
 946                            :soa soa
 947                            :records nil)))
 948       (zone-parse-records zone (cdr zf))
 949       zone)))
 950
 951 (defun zone-create (zf)
 952   "Zone construction function.  Given a zone form ZF, construct the zone and
 953 add it to the table."
 954   (let* ((zone (zone-parse zf))
 955          (name (zone-name zone)))
 956     (setf (zone-find name) zone)
 957     name))
 958
 959 (defmacro defzone (soa &rest zf)
 960   "Zone definition macro."
 961   `(zone-create '(,soa ,@zf)))
 962
 963 (defmacro defrevzone (head &rest zf)
 964   "Define a reverse zone, with the correct name."
 965   (destructuring-bind
 966       (net &rest soa-args)
 967       (listify head)
 968     (let ((bytes nil))
 969       (when (and soa-args (integerp (car soa-args)))
 970         (setf bytes (pop soa-args)))
 971       `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
 972
 973 ;;;--------------------------------------------------------------------------
 974 ;;; Zone record parsers.
 975
 976 (defzoneparse :a (name data rec :defsubp defsubp)
 977   ":a IPADDR"
 978   (rec :data (parse-ipaddr data) :defsubp defsubp))
 979
 980 (defzoneparse :ptr (name data rec :zname zname)
 981   ":ptr HOST"
 982   (rec :data (zone-parse-host data zname)))
 983
 984 (defzoneparse :cname (name data rec :zname zname)
 985   ":cname HOST"
 986   (rec :data (zone-parse-host data zname)))
 987
 988 (defzoneparse :mx (name data rec :zname zname)
 989   ":mx ((HOST :prio INT :ip IPADDR)*)"
 990   (dolist (mx (listify data))
 991     (destructuring-bind
 992         (mxname &key (prio *default-mx-priority*) ip)
 993         (listify mx)
 994       (let ((host (zone-parse-host mxname zname)))
 995         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
 996         (rec :data (cons host prio))))))
 997
 998 (defzoneparse :ns (name data rec :zname zname)
 999   ":ns ((HOST :ip IPADDR)*)"
1000   (dolist (ns (listify data))
1001     (destructuring-bind
1002         (nsname &key ip)
1003         (listify ns)
1004       (let ((host (zone-parse-host nsname zname)))
1005         (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
1006         (rec :data host)))))
1007
1008 (defzoneparse :alias (name data rec :zname zname)
1009   ":alias (LABEL*)"
1010   (dolist (a (listify data))
1011     (rec :name (zone-parse-host a zname)
1012          :type :cname
1013          :data name)))
1014
1015 (defzoneparse :net (name data rec)
1016   ":net (NETWORK*)"
1017   (dolist (net (listify data))
1018     (let ((n (net-get-as-ipnet net)))
1019       (rec :name (zone-parse-host "net" name)
1020            :type :a
1021            :data (ipnet-net n))
1022       (rec :name (zone-parse-host "mask" name)
1023            :type :a
1024            :data (ipnet-mask n))
1025       (rec :name (zone-parse-host "broadcast" name)
1026            :type :a
1027            :data (ipnet-broadcast n)))))
1028
1029 (defzoneparse (:rev :reverse) (name data rec)
1030   ":reverse ((NET :bytes BYTES) ZONE*)"
1031   (setf data (listify data))
1032   (destructuring-bind
1033       (net &key bytes)
1034       (listify (car data))
1035     (setf net (zone-parse-net net name))
1036     (unless bytes
1037       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
1038     (dolist (z (or (cdr data)
1039                    (hash-table-keys *zones*)))
1040       (dolist (zr (zone-records (zone-find z)))
1041         (when (and (eq (zr-type zr) :a)
1042                    (not (zr-defsubp zr))
1043                    (ipaddr-networkp (zr-data zr) net))
1044           (rec :name (string-downcase
1045                       (join-strings
1046                        #\.
1047                        (collecting ()
1048                          (dotimes (i bytes)
1049                            (collect (logand #xff (ash (zr-data zr)
1050                                                       (* -8 i)))))
1051                          (collect name))))
1052                :type :ptr
1053                :ttl (zr-ttl zr)
1054                :data (zr-name zr)))))))
1055
1056 (defzoneparse (:cidr-delegation :cidr) (name data rec)
1057   ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
1058   (destructuring-bind
1059       (net &key bytes)
1060       (listify (car data))
1061     (setf net (zone-parse-net net name))
1062     (unless bytes
1063       (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
1064     (dolist (map (cdr data))
1065       (destructuring-bind
1066           (tnet &optional tdom)
1067           (listify map)
1068         (setf tnet (zone-parse-net tnet name))
1069         (unless (ipnet-subnetp net tnet)
1070           (error "~A is not a subnet of ~A."
1071                  (ipnet-pretty tnet)
1072                  (ipnet-pretty net)))
1073         (unless tdom
1074           (with-ipnet (net mask) tnet
1075             (setf tdom
1076                   (join-strings
1077                    #\.
1078                    (append (reverse (loop
1079                                        for i from (1- bytes) downto 0
1080                                        until (zerop (logand mask
1081                                                             (ash #xff
1082                                                                  (* 8 i))))
1083                                        collect (logand #xff
1084                                                        (ash net (* -8 i)))))
1085                            (list name))))))
1086         (setf tdom (string-downcase tdom))
1087         (dotimes (i (ipnet-hosts tnet))
1088           (let* ((addr (ipnet-host tnet i))
1089                  (tail (join-strings #\.
1090                                      (loop
1091                                         for i from 0 below bytes
1092                                         collect
1093                                           (logand #xff
1094                                                   (ash addr (* 8 i)))))))
1095             (rec :name (format nil "~A.~A" tail name)
1096                  :type :cname
1097                  :data (format nil "~A.~A" tail tdom))))))))
1098
1099 ;;;--------------------------------------------------------------------------
1100 ;;; Zone file output.
1101
1102 (defun zone-write (zone &optional (stream *standard-output*))
1103   "Write a ZONE's records to STREAM."
1104   (labels ((fix-admin (a)
1105              (let ((at (position #\@ a))
1106                    (s (concatenate 'string (string-downcase a) ".")))
1107                (when s
1108                  (setf (char s at) #\.))
1109                s))
1110            (fix-host (h)
1111              (if (not h)
1112                  "@"
1113                  (let* ((h (string-downcase (stringify h)))
1114                         (hl (length h))
1115                         (r (string-downcase (zone-name zone)))
1116                         (rl (length r)))
1117                    (cond ((string= r h) "@")
1118                          ((and (> hl rl)
1119                                (char= (char h (- hl rl 1)) #\.)
1120                                (string= h r :start1 (- hl rl)))
1121                           (subseq h 0 (- hl rl 1)))
1122                          (t (concatenate 'string h "."))))))
1123            (printrec (zr)
1124              (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
1125                      (fix-host (zr-name zr))
1126                      (and (/= (zr-ttl zr) (zone-default-ttl zone))
1127                           (zr-ttl zr))
1128                      (string-upcase (symbol-name (zr-type zr))))))
1129     (format stream "~
1130 ;;; Zone file `~(~A~)'
1131 ;;;   (generated ~A)
1132
1133 $ORIGIN ~@0*~(~A.~)
1134 $TTL ~@2*~D~2%"
1135             (zone-name zone)
1136             (iso-date :now :datep t :timep t)
1137             (zone-default-ttl zone))
1138     (let ((soa (zone-soa zone)))
1139       (format stream "~
1140 ~A~30TIN SOA~40T~A ~A (
1141 ~45T~10D~60T ;serial
1142 ~45T~10D~60T ;refresh
1143 ~45T~10D~60T ;retry
1144 ~45T~10D~60T ;expire
1145 ~45T~10D )~60T ;min-ttl~2%"
1146               (fix-host (zone-name zone))
1147               (fix-host (soa-source soa))
1148               (fix-admin (soa-admin soa))
1149               (soa-serial soa)
1150               (soa-refresh soa)
1151               (soa-retry soa)
1152               (soa-expire soa)
1153               (soa-min-ttl soa)))
1154     (dolist (zr (zone-records zone))
1155       (case (zr-type zr)
1156         (:a
1157          (printrec zr)
1158          (format stream "~A~%" (ipaddr-string (zr-data zr))))
1159         ((:ptr :cname)
1160          (printrec zr)
1161          (format stream "~A~%" (fix-host (zr-data zr))))
1162         (:ns
1163          (printrec zr)
1164          (format stream "~A~%" (fix-host (zr-data zr))))
1165         (:mx
1166          (printrec zr)
1167          (let ((mx (zr-data zr)))
1168            (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
1169         (:txt
1170          (printrec zr)
1171          (format stream "~S~%" (stringify (zr-data zr))))))))
1172
1173 (defun zone-save (zones)
1174   "Write the named ZONES to files.  If no zones are given, write all the
1175 zones."
1176   (unless zones
1177     (setf zones (hash-table-keys *zones*)))
1178   (safely (safe)
1179     (dolist (z zones)
1180       (let ((zz (zone-find z)))
1181         (unless zz
1182           (error "Unknown zone `~A'." z))
1183         (let ((stream (safely-open-output-stream safe
1184                                                  (format nil
1185                                                          "~(~A~).zone"
1186                                                          z))))
1187           (zone-write zz stream))))))
1188
1189 ;;;----- That's all, folks --------------------------------------------------