mdw@git.distorted.org.uk Git - zone/blob - net.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Network (numbering) tools
   4 ;;;
   5 ;;; (c) 2006 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 (in-package #:net)
  25
  26 ;;;--------------------------------------------------------------------------
  27 ;;; Various random utilities.
  28
  29 (declaim (inline mask))
  30 (defun mask (n)
  31   "Return 2^N - 1: i.e., a mask of N set bits."
  32   (1- (ash 1 n)))
  33
  34 (defun find-first-bit-transition
  35     (mask &optional (low 0) (high (integer-length mask)))
  36   "Find the first (lowest bit-position) transition in MASK within the bounds.
  37
  38    The LOW bound is inclusive; the high bound is exclusive.  A transition is
  39    a change from zero to one, or vice-versa.  The return value is the
  40    upper (exclusive) bound on the initial run, and the lower (inclusive)
  41    bound on the new run.
  42
  43    If there is no transition within the bounds, then return HIGH."
  44
  45   ;; Arrange that the initial run is ones.
  46   (unless (logbitp low mask) (setf mask (lognot mask)))
  47
  48   ;; Now, note that MASK + 2^LOW is identical to MASK in all bit positions
  49   ;; except for (a) the run of one bits starting at LOW, and (b) the zero bit
  50   ;; just above it.  So MASK xor (MASK + 2^LOW) is zero except for these
  51   ;; bits; so all we need now is to find the position of its most significant
  52   ;; set bit.
  53   (let ((pos (1- (integer-length (logxor mask (+ mask (ash 1 low)))))))
  54     (if (<= low pos high) pos high)))
  55
  56 (defun count-low-zero-bits (n)
  57   "Return the number of low-order zero bits in the integer N."
  58   (cond ((zerop n) nil)
  59         ((oddp n) 0)
  60         (t (find-first-bit-transition n))))
  61
  62 (declaim (inline round-down))
  63 (defun round-down (n step)
  64   "Return the largest multiple of STEP not greater than N."
  65   (* step (floor n step)))
  66
  67 (declaim (inline round-up))
  68 (defun round-up (n step)
  69   "Return the smallest multiple of STEP not less than N."
  70   (* step (ceiling n step)))
  71
  72 (defgeneric extract-class-name (object)
  73   (:documentation "Turn OBJECT into a class name.")
  74   (:method ((instance standard-object))
  75     (extract-class-name (class-of instance)))
  76   (:method ((class standard-class))
  77     (class-name class))
  78   (:method ((name symbol))
  79     name))
  80
  81 (defclass savable-object ()
  82   ())
  83 (defmethod make-load-form ((object savable-object) &optional environment)
  84   (make-load-form-saving-slots object :environment environment))
  85
  86 ;;;--------------------------------------------------------------------------
  87 ;;; Parsing primitives for addresses.
  88
  89 (defun parse-partial-address
  90     (str
  91      &key (start 0) (end nil) (delim #\.)
  92           (width 8) (radix 10) (min 1) (max 32) (shiftp t)
  93           (what "address"))
  94   "Parse a partial address from STR, which should be a sequence of integers
  95    in the given RADIX, separated by the DELIM character, with each integer
  96    N_i in the interval 0 <= N_i < 2^WIDTH.  If the sequence is N_1, N_2, ...,
  97    N_k, then the basic partial address BPA is the sum
  98
  99         SUM_{1<=i<=k} 2^{WIDTH (k-i)} N_i
 100
 101    If SHIFTP is true (the default) then let OFFSET be the smallest multiple
 102    of WIDTH not less than MAX - k WIDTH; otherwise, let OFFSET be zero.  The
 103    partial address PA is BPA 2^SHIFT.
 104
 105    The return values are: PA, OFFSET, k WIDTH + OFFSET; i.e., the partial
 106    address, and (inclusive) lower and (exclusive) upper bounds on the bits
 107    specified by STR."
 108
 109   (setf-default end (length str))
 110   (let ((addr 0) (nbits 0) (limit (ash 1 width)))
 111     (when (< start end)
 112       (loop
 113         (when (>= nbits max)
 114           (error "Too many elements in ~A" what))
 115         (let* ((pos (position delim str :start start :end end))
 116                (w (parse-integer str :radix radix
 117                                  :start start :end (or pos end))))
 118           (unless (and (<= 0 w) (< w limit))
 119             (error "Element out of range in ~A" what))
 120           (setf addr (logior (ash addr width) w))
 121           (incf nbits width)
 122           (unless pos (return))
 123           (setf start (1+ pos)))))
 124     (when (< nbits min)
 125       (error "Not enough elements in ~A" what))
 126     (if shiftp
 127         (let* ((top (round-up max width))
 128                (shift (- top nbits)))
 129           (values (ash addr shift) shift top))
 130         (values addr 0 nbits))))
 131
 132 ;;;--------------------------------------------------------------------------
 133 ;;; Simple messing about with IP addresses.
 134
 135 (export 'ipaddr)
 136 (export 'ipaddr-addr)
 137 (defclass ipaddr (savable-object)
 138   ()
 139   (:documentation
 140    "Base class for IP addresses."))
 141
 142 (export 'ipaddr-family)
 143 (defgeneric ipaddr-family (addr))
 144
 145 (export 'family-addrclass)
 146 (defgeneric family-addrclass (family)
 147   (:method ((af symbol)) nil))
 148
 149 (export 'ipaddr-width)
 150 (defgeneric ipaddr-width (class)
 151   (:method ((object t)) (ipaddr-width (extract-class-name object))))
 152
 153 (export 'ipaddr-comparable-p)
 154 (defgeneric ipaddr-comparable-p (addr-a addr-b)
 155   (:method ((addr-a ipaddr) (addr-b ipaddr))
 156     (eq (class-of addr-a) (class-of addr-b))))
 157
 158 (defun guess-address-class (str &key (start 0) (end nil))
 159   (cond ((position #\: str :start start :end end) 'ip6addr)
 160         (t 'ip4addr)))
 161
 162 (defgeneric parse-partial-ipaddr (class str &key start end min max)
 163   (:method ((object t) str &rest keywords)
 164     (apply #'parse-partial-ipaddr (extract-class-name object) str keywords)))
 165
 166 (export 'string-ipaddr)
 167 (defun string-ipaddr (str &key (start 0) (end nil))
 168   "Parse STR into an address; guess what kind is intended by the user.
 169
 170    STR may be anything at all: it's converted as if by `stringify'.
 171    The START and END arguments may be used to parse out a substring."
 172   (setf str (stringify str))
 173   (let* ((class (guess-address-class str :start start :end end))
 174          (width (ipaddr-width class)))
 175     (make-instance class :addr
 176                    (parse-partial-ipaddr class str
 177                                          :start start :end end
 178                                          :min width :max width))))
 179
 180 (export 'integer-ipaddr)
 181 (defgeneric integer-ipaddr (int like)
 182   (:documentation "Convert INT into an address of type indicated by LIKE.
 183
 184    Specifically, if LIKE is an address object, then use its type; if it's
 185    a class, then use it directly; if it's a symbol, then use the class it
 186    names.")
 187   (:method (int (like t)) (integer-ipaddr int (class-of like)))
 188   (:method (int (like symbol))
 189     (make-instance (or (family-addrclass like) like) :addr int))
 190   (:method (int (like standard-class)) (make-instance like :addr int)))
 191
 192 (export 'ipaddr-string)
 193 (defgeneric ipaddr-string (ip)
 194   (:documentation
 195    "Transform the address IP into a string in dotted-quad form."))
 196
 197 (defmethod print-object ((addr ipaddr) stream)
 198   (print-unreadable-object (addr stream :type t)
 199     (write-string (ipaddr-string addr) stream)))
 200
 201 (export 'ipaddrp)
 202 (defun ipaddrp (ip)
 203   "Answer true if IP is a valid IP address in integer form."
 204   (typep ip 'ipaddr))
 205
 206 (defun ipaddr (ip &optional like)
 207   "Convert IP to an IP address, of type similar to LIKE.
 208
 209    If it's an IP address, just return it unchanged; If it's an integer,
 210    capture it; otherwise convert by `string-ipaddr'."
 211   (typecase ip
 212     (ipaddr ip)
 213     (integer (integer-ipaddr ip like))
 214     (t (string-ipaddr ip))))
 215
 216 (export 'ipaddr-rrtype)
 217 (defgeneric ipaddr-rrtype (addr)
 218   (:documentation "Return the proper resource record type for ADDR."))
 219
 220 ;;;--------------------------------------------------------------------------
 221 ;;; Netmasks.
 222
 223 (export 'integer-netmask)
 224 (defun integer-netmask (n i)
 225   "Given an integer I, return an N-bit netmask with its I top bits set."
 226   (- (ash 1 n) (ash 1 (- n i))))
 227
 228 (export 'ipmask-cidl-slash)
 229 (defun ipmask-cidl-slash (width mask)
 230   "Given a netmask MASK, try to compute a prefix length.
 231
 232    Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if
 233    this is impossible."
 234   (let* ((low (logxor mask (mask width)))
 235          (bits (integer-length low)))
 236     (and (= low (mask bits)) (- width bits))))
 237
 238 (export 'ipmask)
 239 (defgeneric ipmask (addr mask)
 240   (:documentation "Convert MASK into a suitable netmask for ADDR.")
 241   (:method ((addr ipaddr) (mask null))
 242     (mask (ipaddr-width addr)))
 243   (:method ((addr ipaddr) (mask integer))
 244     (let ((w (ipaddr-width addr)))
 245       (if (<= 0 mask w)
 246           (integer-netmask w mask)
 247           (error "Prefix length out of range.")))))
 248
 249 (export 'mask-ipaddr)
 250 (defun mask-ipaddr (addr mask)
 251   "Apply the MASK to the ADDR, returning the base address."
 252   (integer-ipaddr (logand mask (ipaddr-addr addr)) addr))
 253
 254 ;;;--------------------------------------------------------------------------
 255 ;;; Networks: pairing an address and netmask.
 256
 257 (export 'ipnet)
 258 (export 'ipnet-net)
 259 (export 'ipnet-mask)
 260 (defclass ipnet (savable-object)
 261   ()
 262   (:documentation "Base class for IP networks."))
 263
 264 (export 'ipnet-family)
 265 (defgeneric ipnet-family (ipn)
 266   (:method ((ipn ipnet)) (ipaddr-family (ipnet-net ipn))))
 267
 268 (export 'ipnet-addr)
 269 (defun ipnet-addr (ipn)
 270   "Return the base network address of IPN as a raw integer."
 271   (ipaddr-addr (ipnet-net ipn)))
 272
 273 (export 'ipaddr-ipnet)
 274 (defgeneric ipaddr-ipnet (addr mask)
 275   (:documentation "Construct an `ipnet' object given a base ADDR and MASK."))
 276
 277 (export 'make-ipnet)
 278 (defun make-ipnet (net mask)
 279   "Construct an IP-network object given the NET and MASK; these are
 280    transformed as though by `ipaddr' and `ipmask'."
 281   (let* ((net (ipaddr net))
 282          (mask (ipmask net mask)))
 283     (ipaddr-ipnet (mask-ipaddr net mask) mask)))
 284
 285 (export 'with-ipnet)
 286 (defmacro with-ipnet ((net addr mask) ipn &body body)
 287   "Evaluate the BODY with components of IPN in scope.
 288
 289    The NET is bound to the underlying network base address, as an `ipaddr';
 290    ADDR is bound to the integer value of this address; and MASK is bound to
 291    the netmask, again as an integer.  Any (or all) of these may be nil if not
 292    wanted."
 293   (with-gensyms tmp
 294     `(let ((,tmp ,ipn))
 295        (let (,@(and net `((,net (ipnet-net ,tmp))))
 296              ,@(and addr `((,addr (ipnet-addr ,tmp))))
 297              ,@(and mask `((,mask (ipnet-mask ,tmp)))))
 298          ,@body))))
 299
 300 (export 'ipnet-width)
 301 (defun ipnet-width (ipn)
 302   "Return the underlying bit width of the addressing system."
 303   (ipaddr-width (ipnet-net ipn)))
 304
 305 (export 'ipnet-string)
 306 (defun ipnet-string (ipn)
 307   "Convert IPN to a string."
 308   (with-ipnet (net nil mask) ipn
 309     (format nil "~A/~A"
 310             (ipaddr-string net)
 311             (or (ipmask-cidl-slash (ipnet-width ipn) mask)
 312                 (ipaddr-string (make-instance (class-of net) :addr mask))))))
 313
 314 (defmethod print-object ((ipn ipnet) stream)
 315   (print-unreadable-object (ipn stream :type t)
 316     (write-string (ipnet-string ipn) stream)))
 317
 318 (defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t))
 319   "Parse a subnet description from a (substring of) STR."
 320   (setf-default end (length str))
 321   (let ((sl (and slashp (position #\/ str :start start :end end))))
 322     (multiple-value-bind (addr lo hi)
 323         (parse-partial-ipaddr class str :max max
 324                               :start start :end (or sl end))
 325       (let* ((present (integer-netmask hi (- hi lo)))
 326              (mask (cond ((not sl)
 327                           present)
 328                          ((every #'digit-char-p (subseq str (1+ sl) end))
 329                           (let ((length (parse-integer str
 330                                                        :start (1+ sl)
 331                                                        :end end)))
 332                             (unless (>= length (- width max))
 333                               (error "Mask doesn't reach subnet boundary"))
 334                             (integer-netmask max (- length (- width max)))))
 335                          (t
 336                           (parse-partial-ipaddr class str :max max
 337                                                 :start (1+ sl) :end end)))))
 338         (unless (zerop (logandc2 mask present))
 339           (error "Mask selects bits not present in base address"))
 340         (values addr mask)))))
 341
 342 (defun check-subipnet (base-ipn sub-addr sub-mask)
 343   "Verify that SUB-NET/SUB-MASK is an appropriate subnet of BASE-IPN.
 344
 345    The BASE-IPN is an `ipnet'; SUB-ADDR and SUB-MASK are plain integers.  If
 346    the subnet is invalid (i.e., the subnet disagrees with its putative parent
 347    over some of the fixed address bits) then an error is signalled; otherwise
 348    return the combined base address (as an `ipaddr') and mask (as an
 349    integer)."
 350   (with-ipnet (base-net base-addr base-mask) base-ipn
 351     (let* ((common (logand base-mask sub-mask))
 352            (base-overlap (logand base-addr common))
 353            (sub-overlap (logand sub-addr common))
 354            (full-mask (logior base-mask sub-mask)))
 355       (unless (or (zerop sub-overlap) (= sub-overlap base-overlap))
 356         (error "Subnet doesn't match base network"))
 357       (values (integer-ipaddr (logand full-mask (logior base-addr sub-addr))
 358                               base-net)
 359               full-mask))))
 360
 361 (export 'string-ipnet)
 362 (defun string-ipnet (str &key (start 0) (end nil))
 363   "Parse an IP-network from the string STR."
 364   (setf str (stringify str))
 365   (setf-default end (length str))
 366   (let ((addr-class (guess-address-class str :start start :end end)))
 367     (multiple-value-bind (addr mask)
 368         (let ((width (ipaddr-width addr-class)))
 369           (parse-subnet addr-class width width str
 370                         :start start :end end))
 371       (make-ipnet (make-instance addr-class :addr addr)
 372                   (make-instance addr-class :addr mask)))))
 373
 374 (defun parse-subipnet (ipn str &key (start 0) (end nil) (slashp t))
 375   "Parse STR as a subnet of IPN.
 376
 377    This is mostly a convenience interface over `parse-subnet'."
 378   (let* ((addr-class (extract-class-name (ipnet-net ipn)))
 379          (width (ipaddr-width addr-class))
 380          (max (- width
 381                  (or (ipmask-cidl-slash width (ipnet-mask ipn))
 382                      (error "Base network has complex netmask")))))
 383     (multiple-value-bind (addr mask)
 384         (parse-subnet addr-class width max (stringify str)
 385                       :start start :end end :slashp slashp)
 386       (check-subipnet ipn addr mask))))
 387
 388 (export 'string-subipnet)
 389 (defun string-subipnet (ipn str &key (start 0) (end nil))
 390   "Parse an IP subnet from a parent net IPN and a suffix string STR."
 391   (multiple-value-bind (addr mask)
 392       (parse-subipnet ipn str :start start :end end)
 393     (ipaddr-ipnet addr mask)))
 394
 395 (defun ipnet (net)
 396   "Construct an IP-network object from the given argument.
 397
 398    A number of forms are acceptable:
 399
 400      * ADDR -- a single address, equivalent to (ADDR . N).
 401      * (NET . MASK|nil) -- a single-object representation.
 402      * IPNET -- return an equivalent (`equal', not necessarily `eql')
 403        version."
 404   (typecase net
 405     (ipnet net)
 406     ((or string symbol) (string-ipnet net))
 407     (t (apply #'make-ipnet (pairify net nil)))))
 408
 409 (export 'ipnet-broadcast)
 410 (defgeneric ipnet-broadcast (ipn)
 411   (:documentation "Return the broadcast address for the network IPN.
 412
 413    Returns nil if there isn't one."))
 414
 415 (export 'ipnet-hosts)
 416 (defun ipnet-hosts (ipn)
 417   "Return the number of available addresses in network IPN."
 418   (ash 1 (- (ipnet-width ipn) (logcount (ipnet-mask ipn)))))
 419
 420 (defstruct host-map
 421   "An internal object used by `ipnet-index-host' and `ipnet-host-index'.
 422
 423    Our objective is to be able to convert between flat host indices and a
 424    possibly crazy non-flat host space.  We record the underlying IPNET for
 425    convenience, and a list of byte-specifications for the runs of zero bits
 426    in the netmask, in ascending order."
 427   ipnet
 428   bytes)
 429
 430 (export 'ipnet-host-map)
 431 (defun ipnet-host-map (ipn)
 432   "Work out how to enumerate the variable portion of IPN.
 433
 434    Returns an object which can be passed to `ipnet-index-host' and
 435    `ipnet-host-index'."
 436   (let* ((mask (ipnet-mask ipn)) (bytes nil) (i 0)
 437          (len (integer-length mask)) (width (ipnet-width ipn)))
 438     (when (logbitp i mask) (setf i (find-first-bit-transition mask i)))
 439     (loop
 440       (unless (< i len) (return))
 441       (let ((next (find-first-bit-transition mask i width)))
 442         (push (byte (- next i) i) bytes)
 443         (setf i (find-first-bit-transition mask next width))))
 444     (when (< len width) (push (byte (- width len) len) bytes))
 445     (make-host-map :ipnet ipn :bytes (nreverse bytes))))
 446
 447 (export 'ipnet-index-host)
 448 (defun ipnet-index-host (map host)
 449   "Convert a HOST index to its address."
 450   (let* ((ipn (host-map-ipnet map))
 451          (addr (logand (ipnet-addr ipn) (ipnet-mask ipn))))
 452     (dolist (byte (host-map-bytes map))
 453       (setf (ldb byte addr) host
 454             host (ash host (- (byte-size byte)))))
 455     (unless (zerop host)
 456       (error "Host index out of range."))
 457     (integer-ipaddr addr (ipnet-net ipn))))
 458
 459 (export 'ipnet-host-index)
 460 (defun ipnet-host-index (map addr)
 461   "Convert an ADDR into a host index."
 462   (let ((addr (ipaddr-addr addr))
 463         (host 0) (offset 0))
 464     (dolist (byte (host-map-bytes map))
 465       (setf host (logior host
 466                          (ash (ldb byte addr) offset))
 467             offset (+ offset (byte-size byte))))
 468     host))
 469
 470 (export 'ipnet-index-bounds)
 471 (defun ipnet-index-bounds (map start end)
 472   "Return host-index bounds corresponding to the given bit-position bounds."
 473   (flet ((hack (frob-map good-byte tweak-addr)
 474            (dolist (byte (funcall frob-map (host-map-bytes map)))
 475              (let* ((low (byte-position byte))
 476                     (high (+ low (byte-size byte)))
 477                     (good (funcall good-byte low high)))
 478                (when good
 479                  (return-from hack
 480                    (ipnet-host-index map
 481                                      (ipaddr (funcall tweak-addr
 482                                                       (ash 1 good))
 483                                              (ipnet-net
 484                                               (host-map-ipnet map))))))))
 485            (error "No variable bits in range.")))
 486     (values (hack #'identity
 487                   (lambda (low high)
 488                     (and (< start high) (max start low)))
 489                   #'identity)
 490             (hack #'reverse
 491                   (lambda (low high)
 492                     (and (>= end low) (min end high)))
 493                   #'1-))))
 494
 495 (export 'ipnet-host)
 496 (defun ipnet-host (ipn host)
 497   "Return the address of the given HOST in network IPN.
 498
 499    The HOST may be a an integer index into the network (this works even with
 500    a non-contiguous netmask) or a string or symbolic suffix (as for
 501    `string-subnet')."
 502   (etypecase host
 503     (integer
 504      (ipnet-index-host (ipnet-host-map ipn) host))
 505     ((or symbol string)
 506      (multiple-value-bind (addr mask)
 507          (parse-subipnet ipn host :slashp nil)
 508        (unless (= mask (mask (ipaddr-width addr)))
 509          (error "Host address incomplete"))
 510        addr))))
 511
 512 (export 'ipaddr-networkp)
 513 (defun ipaddr-networkp (ip ipn)
 514   "Returns true if numeric address IP is within network IPN."
 515   (with-ipnet (nil addr mask) ipn
 516     (= addr (logand ip mask))))
 517
 518 (export 'ipnet-subnetp)
 519 (defun ipnet-subnetp (ipn subn)
 520   "Returns true if SUBN is a (non-strict) subnet of IPN."
 521   (with-ipnet (net addr mask) ipn
 522     (with-ipnet (subnet subaddr submask) subn
 523       (and (ipaddr-comparable-p net subnet)
 524            (= addr (logand subaddr mask))
 525            (= submask (logior mask submask))))))
 526
 527 (export 'ipnet-overlapp)
 528 (defun ipnet-overlapp (ipn-a ipn-b)
 529   "Returns true if IPN-A and IPN-B have any addresses in common."
 530   (with-ipnet (net-a addr-a mask-a) ipn-a
 531     (with-ipnet (net-b addr-b mask-b) ipn-b
 532
 533       ;; In the case of an overlap, we explicitly construct a common
 534       ;; address.  If this fails, we know that the networks don't overlap
 535       ;; after all.
 536       (flet ((narrow (addr-a mask-a addr-b mask-b)
 537                ;; Narrow network A towards B, by setting bits in A's base
 538                ;; address towards which A is indifferent, but B is not;
 539                ;; return the resulting base address.  This address is still
 540                ;; within network A, since we only set bits to which A is
 541                ;; indifferent.
 542                (logior addr-a (logand addr-b (logandc2 mask-a mask-b)))))
 543
 544         (and (ipaddr-comparable-p net-a net-b)
 545              (= (narrow addr-a mask-a addr-b mask-b)
 546                 (narrow addr-b mask-b addr-a mask-a)))))))
 547
 548 (export 'ipnet-changeable-bits)
 549 (defun ipnet-changeable-bits (width mask)
 550   "Work out the number of changeable bits in a network, given its MASK.
 551
 552    This is a conservative estimate in the case of noncontiguous masks.  The
 553    WIDTH is the total width of an address."
 554
 555   ;; We bisect the address.  If the low-order bits are changeable then we
 556   ;; recurse on them; otherwise we look at the high-order bits.  A mask M of
 557   ;; width W is changeable if it's not all-ones, i.e., if M /= 2^W.  If the
 558   ;; top half is changeable then we don't need to look at the bottom half.
 559   (labels ((recurse (width mask offset)
 560              (if (= width 1)
 561                  (if (zerop mask) (1+ offset) offset)
 562                  (let* ((lowwidth (floor width 2))
 563                         (highwidth (- width lowwidth))
 564                         (highmask (ash mask (- lowwidth))))
 565                    (if (logbitp highwidth (1+ highmask))
 566                        (recurse lowwidth
 567                                 (logand mask (mask lowwidth))
 568                                 offset)
 569                        (recurse highwidth highmask (+ offset lowwidth)))))))
 570     (recurse width mask 0)))
 571
 572 ;;;--------------------------------------------------------------------------
 573 ;;; Reverse lookups.
 574
 575 (export 'reverse-domain-component-width)
 576 (defgeneric reverse-domain-component-width (ipaddr)
 577   (:documentation "Return the component width for splitting IPADDR."))
 578
 579 (export 'reverse-domain-component-radix)
 580 (defgeneric reverse-domain-radix (ipaddr)
 581   (:documentation "Return the radix for representing IPADDR components."))
 582
 583 (export 'reverse-domain-component-suffix)
 584 (defgeneric reverse-domain-suffix (ipaddr)
 585   (:documentation "Return the reverse-lookup domain suffix for IPADDR."))
 586
 587 (export 'reverse-domain-fragment)
 588 (defgeneric reverse-domain-fragment (ipaddr start end &key partialp)
 589   (:documentation
 590    "Return a portion of an IPADDR's reverse-resolution domain name.
 591
 592    Specifically, return the portion of the name which covers the bits of an
 593    IPADDR between bits START (inclusive) and END (exclusive).  Address
 594    components which are only partially within the given bounds are included
 595    unless PARTIALP is nil.")
 596   (:method ((ipaddr ipaddr) start end &key (partialp t))
 597
 598     (let ((addr (ipaddr-addr ipaddr))
 599           (comp-width (reverse-domain-component-width ipaddr))
 600           (radix (reverse-domain-radix ipaddr)))
 601
 602       (with-output-to-string (out)
 603         (do ((i (funcall (if partialp #'round-down #'round-up)
 604                          start comp-width)
 605                 (+ i comp-width))
 606              (limit (funcall (if partialp #'round-up #'round-down)
 607                              end comp-width))
 608              (sep nil t))
 609             ((>= i limit))
 610           (format out "~:[~;.~]~(~vR~)"
 611                   sep radix (ldb (byte comp-width i) addr)))))))
 612
 613 (export 'reverse-domain)
 614 (defgeneric reverse-domain (ipaddr-or-ipn &optional prefix-len)
 615   (:documentation "Return a reverse-resolution domain name for IPADDR-OR-IPN.
 616
 617    If PREFIX-LEN is nil then it defaults to the length of the network's fixed
 618    prefix.")
 619   (:method ((ipn ipnet) &optional prefix-len)
 620     (let* ((addr (ipnet-net ipn))
 621            (mask (ipnet-mask ipn))
 622            (width (ipaddr-width addr)))
 623       (concatenate 'string
 624                    (reverse-domain-fragment
 625                     addr
 626                     (if prefix-len
 627                         (- width prefix-len)
 628                         (ipnet-changeable-bits width mask))
 629                     width
 630                     :partialp nil)
 631                    "."
 632                    (reverse-domain-suffix addr))))
 633   (:method ((addr ipaddr) &optional prefix-len)
 634     (let* ((width (ipaddr-width addr)))
 635       (reverse-domain (make-ipnet addr (mask width))
 636                       (or prefix-len width)))))
 637
 638 ;;;--------------------------------------------------------------------------
 639 ;;; Network names and specifiers.
 640
 641 (export 'net)
 642 (export 'net-name)
 643 (export 'net-ipnets)
 644 (defclass net ()
 645   ((name :type string :initarg :name :reader net-name)
 646    (ipnets :type list :initarg :ipnets :initform nil :accessor net-ipnets)
 647    (next :type unsigned-byte :initform 1 :accessor net-next)))
 648
 649 (defmethod print-object ((net net) stream)
 650   (print-unreadable-object (net stream :type t)
 651     (format stream "~A~@[ = ~{~A~^, ~}~]"
 652             (net-name net)
 653             (mapcar #'ipnet-string (net-ipnets net)))))
 654
 655 (defvar *networks* (make-hash-table :test #'equal)
 656   "The table of known networks.")
 657
 658 (export 'net-find)
 659 (defun net-find (name)
 660   "Find a network by NAME."
 661   (gethash (string-downcase (stringify name)) *networks*))
 662 (defun (setf net-find) (net name)
 663   "Make NAME map to NET."
 664   (setf (gethash (string-downcase (stringify name)) *networks*) net))
 665
 666 (export 'net-must-find)
 667 (defun net-must-find (name)
 668   (or (net-find name)
 669       (error "Unknown network ~A." name)))
 670
 671 (defun net-ipnet (net family)
 672   (find family (net-ipnets net) :key #'ipnet-family))
 673 (defun (setf net-ipnet) (ipnet net family)
 674   (assert (eq (ipnet-family ipnet) family))
 675   (let ((ipns (net-ipnets net)))
 676     (if (find family ipns :key #'ipnet-family)
 677         (nsubstitute ipnet family ipns :key #'ipnet-family)
 678         (setf (net-ipnets net) (cons ipnet ipns)))))
 679
 680 (defun process-net-form (name addr subnets)
 681   "Unpack a net-form.
 682
 683    A net-form looks like (NAME ADDR [SUBNET ...]) where:
 684
 685      * NAME is the name for the network.
 686
 687      * ADDR is the subnet address (acceptable to `string-subipnet'); at
 688        top-level, this is a plain network address (acceptable to
 689        `string-ipnet').  Alternatively (for compatibility) the ADDR for a
 690        non-top-level network can be an integer number of addresses to
 691        allocate to this subnet; the subnet's base address is implicitly just
 692        past the previous subnet's limit address (or, for the first subnet,
 693        it's the parent network's base address).  This won't work at all well
 694        if your subnets have crazy netmasks.
 695
 696      * The SUBNETs are further net-forms, of the same form, whose addresses
 697        are interpreted relative to the parent network's address.
 698
 699    The return value is a list of items of the form (NAME . IPNET)."
 700
 701   (labels ((process-subnets (subnets parent)
 702              (let ((finger (ipnet-addr parent))
 703                    (list nil))
 704                (dolist (subnet subnets list)
 705                  (destructuring-bind (name addr &rest subs) subnet
 706                    (let ((net (etypecase addr
 707                                 (integer
 708                                  (when (or (> (count-low-zero-bits addr)
 709                                               (count-low-zero-bits finger))
 710                                            (not (zerop (logand addr
 711                                                                (1- addr)))))
 712                                    (error "Bad subnet size for ~A." name))
 713                                  (make-ipnet
 714                                   (ipaddr finger (ipnet-net parent))
 715                                   (ipaddr (- (ash 1 (ipnet-width parent))
 716                                              addr)
 717                                           (ipnet-net parent))))
 718                                 ((or string symbol)
 719                                  (string-subipnet parent addr)))))
 720
 721                      (unless (ipnet-subnetp parent net)
 722                        (error "Network `~A' (~A) falls outside parent ~A."
 723                               name (ipnet-string net) (ipnet-string parent)))
 724
 725                      (dolist (entry list nil)
 726                        (let ((ipn (cdr entry)))
 727                          (when (ipnet-overlapp ipn net)
 728                            (error "Network `~A' (~A) overlaps `~A' (~A)."
 729                                   name (ipnet-string net)
 730                                   (car entry) (ipnet-string ipn)))))
 731
 732                      (setf finger
 733                            (1+ (logior
 734                                 (ipnet-addr net)
 735                                 (logxor (ipnet-mask net)
 736                                         (1- (ash 1 (ipnet-width net)))))))
 737
 738                      (when name
 739                        (push (cons name net) list))
 740
 741                      (when subs
 742                        (setf list (nconc (process-subnets subs net)
 743                                          list)))))))))
 744
 745     (let* ((top (string-ipnet addr))
 746            (list (nreverse (process-subnets subnets top))))
 747       (when name (push (cons name top) list))
 748       list)))
 749
 750 (export 'net-create)
 751 (defun net-create (name net)
 752   "Construct a new network called NAME and add it to the map.
 753
 754    The NET describes the new network, in a form acceptable to the `ipnet'
 755    function.  A named network may have multiple addresses with different
 756    families: each `net-create' call adds a new family, or modifies the net's
 757    address in an existing family."
 758   (let ((ipn (ipnet net))
 759         (net (net-find name)))
 760     (if net
 761         (progn (setf (net-ipnet net (ipnet-family ipn)) ipn) net)
 762         (setf (net-find name)
 763               (make-instance 'net
 764                              :name (string-downcase (stringify name))
 765                              :ipnets (list ipn))))))
 766
 767 (export 'defnet)
 768 (defmacro defnet (name net &rest subnets)
 769   "Main network definition macro.
 770
 771    None of the arguments is evaluated."
 772   `(progn
 773      ,@(mapcar (lambda (item)
 774                  (let ((name (car item)) (ipn (cdr item)))
 775                    `(net-create ',name ',ipn)))
 776                (process-net-form name net subnets))
 777      ',name))
 778
 779 (defun filter-by-family (func form family)
 780   "Handle a family-switch form.
 781
 782    Here, FUNC is a function of two arguments ITEM and FAMILY.  FORM is either
 783    a list of the form ((FAMILY . ITEM) ...), or an ITEM which is directly
 784    acceptable to FUNC.  Return a list of the resulting outputs of FUNC."
 785
 786   (if (and (listp form)
 787            (every (lambda (clause)
 788                     (and (listp clause)
 789                          (family-addrclass (car clause))))
 790                   form))
 791       (mapcan (lambda (clause)
 792                 (let ((fam (car clause)))
 793                   (and (or (eq family t)
 794                            (eq family fam))
 795                        (list (funcall func (cdr clause) fam)))))
 796               form)
 797       (list (funcall func form family))))
 798
 799 (export 'net-parse-to-ipnets)
 800 (defun net-parse-to-ipnets (form &optional (family t))
 801   (flet ((hack (form family)
 802            (let* ((form (if (and (consp form)
 803                                  (endp (cdr form)))
 804                             (car form)
 805                             form))
 806                   (net (net-find form))
 807                   (ipns (if net (net-ipnets net)
 808                             (list (ipnet form)))))
 809              (if (eq family t) ipns
 810                  (remove family ipns
 811                          :key #'ipnet-family
 812                          :test-not #'eq)))))
 813     (let* ((ipns (apply #'append (filter-by-family #'hack form family)))
 814            (merged (reduce (lambda (ipns ipn)
 815                              (if (find (ipnet-family ipn) ipns
 816                                        :key #'ipnet-family)
 817                                  ipns
 818                                  (cons ipn ipns)))
 819                            ipns
 820                            :initial-value nil)))
 821       (or merged (error "No matching addresses.")))))
 822
 823 (export 'net-host)
 824 (defun net-host (net-form host &optional (family t))
 825   "Return the given HOST on the NET, as an anonymous `host' object.
 826
 827    HOST may be an index (in range, of course), a suffix (as a symbol or
 828    string, as for `string-subnet'), or one of the keywords:
 829
 830    :next       next host, as by net-next-host
 831    :net        network base address
 832    :broadcast  network broadcast address
 833
 834    If FAMILY is not `t', then only return an address with that family;
 835    otherwise return all available addresses."
 836   (flet ((hosts (ipns host)
 837            (mapcar (lambda (ipn) (ipnet-host ipn host))
 838                    (if (integerp host)
 839                        (remove host ipns :key #'ipnet-hosts :test #'>=)
 840                        ipns))))
 841     (let* ((net (and (typep net-form '(or string symbol))
 842                      (net-find net-form)))
 843            (ipns (net-parse-to-ipnets net-form family))
 844            (addrs (case host
 845                     (:next
 846                      (if net
 847                          (prog1 (hosts ipns (net-next net))
 848                            (incf (net-next net)))
 849                          (error "Can't use `:next' without a named net.")))
 850                     (:net (mapcar #'ipnet-net ipns))
 851                     (:broadcast (remove nil (mapcar #'ipnet-broadcast ipns)))
 852                     (t (hosts ipns host)))))
 853       (unless addrs
 854         (error "No networks have that address."))
 855       (make-instance 'host :addrs addrs))))
 856
 857 ;;;--------------------------------------------------------------------------
 858 ;;; Host names and specifiers.
 859
 860 (export 'host)
 861 (export 'host-name)
 862 (export 'host-addrs)
 863 (defclass host ()
 864   ((name :type (or string null) :initform nil
 865          :initarg :name :reader host-name)
 866    (addrs :type list :initarg :addrs :initform nil :accessor host-addrs)))
 867
 868 (defmethod print-object ((host host) stream)
 869   (print-unreadable-object (host stream :type t)
 870     (format stream "~:[<anonymous>~;~@*~A~]~@[ = ~{~A~^, ~}~]"
 871             (host-name host)
 872             (mapcar #'ipaddr-string (host-addrs host)))))
 873
 874 (defvar *hosts* (make-hash-table :test #'equal)
 875   "The table of known hostnames.")
 876
 877 (export 'host-find)
 878 (defun host-find (name)
 879   "Find a host by NAME."
 880   (gethash (string-downcase (stringify name)) *hosts*))
 881 (defun (setf host-find) (addr name)
 882   "Make NAME map to ADDR (must be an ipaddr in integer form)."
 883   (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
 884
 885 (defun merge-addresses (addrs-a addrs-b)
 886   (append (remove-if (lambda (addr)
 887                        (member (ipaddr-family addr) addrs-b
 888                                :key #'ipaddr-family))
 889                      addrs-a)
 890           addrs-b))
 891
 892 (export 'host-parse)
 893 (defun host-parse (addr &optional (family t))
 894   "Convert the ADDR into a (possibly anonymous) `host' object.
 895
 896    The ADDR can be one of a number of different things.
 897
 898    HOST                         a host name defined using `defhost'
 899
 900    (NET INDEX)                  a particular host in a network
 901
 902    IPADDR                       an address form acceptable to `ipnet'
 903
 904    ((FAMILY . ADDR) ...)        the above, restricted to a particular address
 905                                   FAMILY (i.e., one of the keywords `:ipv4',
 906                                   etc.)"
 907
 908   (labels ((filter-addresses (addrs family)
 909              (make-instance 'host
 910                             :addrs (if (eq family t) addrs
 911                                        (remove family addrs
 912                                                :key #'ipaddr-family
 913                                                :test-not #'eq))))
 914            (host-addresses (host family)
 915              (if (eq family t) host
 916                  (filter-addresses (host-addrs host) family)))
 917            (hack (addr family)
 918              (let* ((form (listify addr))
 919                     (indic (car form))
 920                     (host (and (null (cdr form))
 921                                (host-find indic))))
 922                (cond (host
 923                       (host-addresses host family))
 924                      ((and (consp (cdr form))
 925                            (endp (cddr form)))
 926                       (net-host (car form) (cadr form) family))
 927                      (t
 928                       (filter-addresses (list (ipaddr indic)) family))))))
 929     (let* ((list (filter-by-family #'hack addr family))
 930            (host (if (and list (cdr list))
 931                      (make-instance 'host
 932                                     :addrs (reduce #'merge-addresses
 933                                                    (mapcar #'host-addrs
 934                                                            (reverse list))
 935                                                    :initial-value nil))
 936                      (car list))))
 937       (unless (host-addrs host)
 938         (error "No matching addresses."))
 939       host)))
 940
 941 (export 'host-create)
 942 (defun host-create (name addr)
 943   "Make host NAME map to ADDR (anything acceptable to `host-parse')."
 944   (let ((existing (host-find name))
 945         (new (host-parse addr)))
 946     (if (not existing)
 947         (setf (host-find name)
 948               (make-instance 'host
 949                              :name (string-downcase (stringify name))
 950                              :addrs (host-addrs new)))
 951         (progn
 952           (setf (host-addrs existing)
 953                 (merge-addresses (host-addrs existing) (host-addrs new)))
 954           existing))))
 955
 956 (export 'defhost)
 957 (defmacro defhost (name addr)
 958   "Main host definition macro.  Neither NAME nor ADDR is evaluated."
 959   `(progn
 960      (host-create ',name ',addr)
 961      ',name))
 962
 963 ;;;----- That's all, folks --------------------------------------------------