chiark - git - mdw - 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 (defun natural-string< (string1 string2
  87                         &key (start1 0) (end1 nil)
  88                         (start2 0) (end2 nil))
  89   "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.
  90
  91    In particular, digit sequences are handled in a moderately sensible way.
  92    Split the strings into maximally long alternating sequences of non-numeric
  93    and numeric characters, such that the non-numeric sequences are
  94    non-empty.  Compare these lexicographically; numeric sequences order
  95    according to their integer values, non-numeric sequences in the usual
  96    lexicographic ordering.
  97
  98    Returns two values: whether STRING1 strictly precedes STRING2, and whether
  99    STRING1 strictly follows STRING2."
 100
 101   (let ((end1 (or end1 (length string1)))
 102         (end2 (or end2 (length string2))))
 103     (loop
 104       (cond ((>= start1 end1)
 105              (let ((eqp (>= start2 end2)))
 106                (return (values (not eqp) nil))))
 107             ((>= start2 end2)
 108              (return (values nil t)))
 109             ((and (digit-char-p (char string1 start1))
 110                   (digit-char-p (char string2 start2)))
 111              (let* ((lim1 (or (position-if-not #'digit-char-p string1
 112                                                :start start1 :end end1)
 113                               end1))
 114                     (n1 (parse-integer string1 :start start1 :end lim1))
 115                     (lim2 (or (position-if-not #'digit-char-p string2
 116                                                :start start2 :end end2)
 117                               end2))
 118                     (n2 (parse-integer string2 :start start2 :end lim2)))
 119                (cond ((< n1 n2) (return (values t nil)))
 120                      ((> n1 n2) (return (values nil t))))
 121                (setf start1 lim1
 122                      start2 lim2)))
 123             (t
 124              (let ((lim1 (or (position-if #'digit-char-p string1
 125                                           :start start1 :end end1)
 126                              end1))
 127                    (lim2 (or (position-if #'digit-char-p string2
 128                                           :start start2 :end end2)
 129                              end2)))
 130                (cond ((string< string1 string2
 131                                :start1 start1 :end1 lim1
 132                                :start2 start2 :end2 lim2)
 133                       (return (values t nil)))
 134                      ((string> string1 string2
 135                                :start1 start1 :end1 lim1
 136                                :start2 start2 :end2 lim2)
 137                       (return (values nil t))))
 138                (setf start1 lim1
 139                      start2 lim2)))))))
 140
 141 ;;;--------------------------------------------------------------------------
 142 ;;; Parsing primitives for addresses.
 143
 144 (defun parse-partial-address
 145     (str
 146      &key (start 0) (end nil) (delim #\.)
 147           (width 8) (radix 10) (min 1) (max 32) (shiftp t)
 148           (what "address"))
 149   "Parse a partial address from STR, which should be a sequence of integers
 150    in the given RADIX, separated by the DELIM character, with each integer
 151    N_i in the interval 0 <= N_i < 2^WIDTH.  If the sequence is N_1, N_2, ...,
 152    N_k, then the basic partial address BPA is the sum
 153
 154         SUM_{1<=i<=k} 2^{WIDTH (k-i)} N_i
 155
 156    If SHIFTP is true (the default) then let OFFSET be the smallest multiple
 157    of WIDTH not less than MAX - k WIDTH; otherwise, let OFFSET be zero.  The
 158    partial address PA is BPA 2^SHIFT.
 159
 160    The return values are: PA, OFFSET, k WIDTH + OFFSET; i.e., the partial
 161    address, and (inclusive) lower and (exclusive) upper bounds on the bits
 162    specified by STR."
 163
 164   (setf-default end (length str))
 165   (let ((addr 0) (nbits 0) (limit (ash 1 width)))
 166     (when (< start end)
 167       (loop
 168         (when (>= nbits max)
 169           (error "Too many elements in ~A" what))
 170         (let* ((pos (position delim str :start start :end end))
 171                (w (parse-integer str :radix radix
 172                                  :start start :end (or pos end))))
 173           (unless (and (<= 0 w) (< w limit))
 174             (error "Element out of range in ~A" what))
 175           (setf addr (logior (ash addr width) w))
 176           (incf nbits width)
 177           (unless pos (return))
 178           (setf start (1+ pos)))))
 179     (when (< nbits min)
 180       (error "Not enough elements in ~A" what))
 181     (if shiftp
 182         (let* ((top (round-up max width))
 183                (shift (- top nbits)))
 184           (values (ash addr shift) shift top))
 185         (values addr 0 nbits))))
 186
 187 ;;;--------------------------------------------------------------------------
 188 ;;; Simple messing about with IP addresses.
 189
 190 (export 'ipaddr)
 191 (export 'ipaddr-addr)
 192 (defclass ipaddr (savable-object)
 193   ()
 194   (:documentation
 195    "Base class for IP addresses."))
 196
 197 (export 'ipaddr-family)
 198 (defgeneric ipaddr-family (addr)
 199   (:documentation "Return the address family of ADDR, as a keyword."))
 200
 201 (export 'family-addrclass)
 202 (defgeneric family-addrclass (family)
 203   (:documentation "Convert the keyword FAMILY into an `ipaddr' subclass.")
 204   (:method ((af symbol)) nil))
 205
 206 (export 'ipaddr-width)
 207 (defgeneric ipaddr-width (class)
 208   (:documentation "Return the width, in bits, of addresses from CLASS.
 209
 210    Alternatively, the CLASS may be given as an example object.")
 211   (:method ((object t)) (ipaddr-width (extract-class-name object))))
 212
 213 (export 'ipaddr-comparable-p)
 214 (defgeneric ipaddr-comparable-p (addr-a addr-b)
 215   (:documentation "Is it meaningful to compare ADDR-A and ADDR-B?")
 216   (:method ((addr-a ipaddr) (addr-b ipaddr))
 217     (eq (class-of addr-a) (class-of addr-b))))
 218
 219 (defun guess-address-class (str &key (start 0) (end nil))
 220   "Return a class name for the address in (the given substring of) STR.
 221
 222    This ought to be an extension point for additional address families, but
 223    it isn't at the moment."
 224   (cond ((position #\: str :start start :end end) 'ip6addr)
 225         (t 'ip4addr)))
 226
 227 (defgeneric parse-partial-ipaddr (class str &key start end min max)
 228   (:documentation
 229    "Parse (a substring of) STR into a partial address of the given CLASS.
 230
 231    Returns three values: the parsed address fragment, as an integer; and the
 232    low and high bit positions covered by the response.
 233
 234    The CLASS may instead be an example object of the required class.  The MIN
 235    and MAX arguments bound the number of bits acceptable in the response; the
 236    result is shifted so that the most significant component of the returned
 237    address is in the same component as bit position MAX.")
 238   (:method ((object t) str &rest keywords)
 239     (apply #'parse-partial-ipaddr (extract-class-name object) str keywords)))
 240
 241 (export 'string-ipaddr)
 242 (defun string-ipaddr (str &key (start 0) (end nil))
 243   "Parse STR into an address; guess what kind is intended by the user.
 244
 245    STR may be anything at all: it's converted as if by `stringify'.
 246    The START and END arguments may be used to parse out a substring."
 247   (setf str (stringify str))
 248   (let* ((class (guess-address-class str :start start :end end))
 249          (width (ipaddr-width class)))
 250     (make-instance class :addr
 251                    (parse-partial-ipaddr class str
 252                                          :start start :end end
 253                                          :min width :max width))))
 254
 255 (export 'integer-ipaddr)
 256 (defgeneric integer-ipaddr (int like)
 257   (:documentation "Convert INT into an address of type indicated by LIKE.
 258
 259    Specifically, if LIKE is an address object, then use its type; if it's
 260    a class, then use it directly; if it's a symbol, then use the class it
 261    names.")
 262   (:method (int (like t)) (integer-ipaddr int (class-of like)))
 263   (:method (int (like symbol))
 264     (make-instance (or (family-addrclass like) like) :addr int))
 265   (:method (int (like standard-class)) (make-instance like :addr int)))
 266
 267 (export 'ipaddr-string)
 268 (defgeneric ipaddr-string (ip)
 269   (:documentation "Transform the address IP into a numeric textual form."))
 270
 271 (defmethod print-object ((addr ipaddr) stream)
 272   (print-unreadable-object (addr stream :type t)
 273     (write-string (ipaddr-string addr) stream)))
 274
 275 (export 'ipaddrp)
 276 (defun ipaddrp (ip)
 277   "Answer true if IP is a valid IP address in integer form."
 278   (typep ip 'ipaddr))
 279
 280 (defun ipaddr (ip &optional like)
 281   "Convert IP to an IP address, of type similar to LIKE.
 282
 283    If it's an IP address, just return it unchanged; If it's an integer,
 284    capture it; otherwise convert by `string-ipaddr'."
 285   (typecase ip
 286     (ipaddr ip)
 287     (integer (integer-ipaddr ip like))
 288     (t (string-ipaddr ip))))
 289
 290 (export 'ipaddr-rrtype)
 291 (defgeneric ipaddr-rrtype (addr)
 292   (:documentation "Return the proper resource record type for ADDR."))
 293
 294 ;;;--------------------------------------------------------------------------
 295 ;;; Netmasks.
 296
 297 (export 'integer-netmask)
 298 (defun integer-netmask (n i)
 299   "Given an integer I, return an N-bit netmask with its I top bits set."
 300   (- (ash 1 n) (ash 1 (- n i))))
 301
 302 (export 'ipmask-cidl-slash)
 303 (defun ipmask-cidl-slash (width mask)
 304   "Given a netmask MASK, try to compute a prefix length.
 305
 306    Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if
 307    this is impossible."
 308   (let* ((low (logxor mask (mask width)))
 309          (bits (integer-length low)))
 310     (and (= low (mask bits)) (- width bits))))
 311
 312 (export 'ipmask)
 313 (defgeneric ipmask (addr mask)
 314   (:documentation "Convert MASK into a suitable netmask for ADDR.")
 315   (:method ((addr ipaddr) (mask null))
 316     (mask (ipaddr-width addr)))
 317   (:method ((addr ipaddr) (mask integer))
 318     (let ((w (ipaddr-width addr)))
 319       (if (<= 0 mask w)
 320           (integer-netmask w mask)
 321           (error "Prefix length out of range.")))))
 322
 323 (export 'mask-ipaddr)
 324 (defun mask-ipaddr (addr mask)
 325   "Apply the MASK to the ADDR, returning the base address."
 326   (integer-ipaddr (logand mask (ipaddr-addr addr)) addr))
 327
 328 ;;;--------------------------------------------------------------------------
 329 ;;; Networks: pairing an address and netmask.
 330
 331 (export 'ipnet)
 332 (export 'ipnet-net)
 333 (export 'ipnet-mask)
 334 (defclass ipnet (savable-object)
 335   ()
 336   (:documentation "Base class for IP networks."))
 337
 338 (export 'ipnet-family)
 339 (defgeneric ipnet-family (ipn)
 340   (:documentation "Return the address family of IPN, as a keyword.")
 341   (:method ((ipn ipnet)) (ipaddr-family (ipnet-net ipn))))
 342
 343 (export 'ipnet-addr)
 344 (defun ipnet-addr (ipn)
 345   "Return the base network address of IPN as a raw integer."
 346   (ipaddr-addr (ipnet-net ipn)))
 347
 348 (export 'ipaddr-ipnet)
 349 (defgeneric ipaddr-ipnet (addr mask)
 350   (:documentation "Construct an `ipnet' object given a base ADDR and MASK."))
 351
 352 (export 'make-ipnet)
 353 (defun make-ipnet (net mask)
 354   "Construct an IP-network object given the NET and MASK.
 355
 356    These are transformed as though by `ipaddr' and `ipmask'."
 357   (let* ((net (ipaddr net))
 358          (mask (ipmask net mask)))
 359     (ipaddr-ipnet (mask-ipaddr net mask) mask)))
 360
 361 (export 'with-ipnet)
 362 (defmacro with-ipnet ((net addr mask) ipn &body body)
 363   "Evaluate the BODY with components of IPN in scope.
 364
 365    The NET is bound to the underlying network base address, as an `ipaddr';
 366    ADDR is bound to the integer value of this address; and MASK is bound to
 367    the netmask, again as an integer.  Any (or all) of these may be nil if not
 368    wanted."
 369   (with-gensyms tmp
 370     `(let ((,tmp ,ipn))
 371        (let (,@(and net `((,net (ipnet-net ,tmp))))
 372              ,@(and addr `((,addr (ipnet-addr ,tmp))))
 373              ,@(and mask `((,mask (ipnet-mask ,tmp)))))
 374          ,@body))))
 375
 376 (export 'ipnet-width)
 377 (defun ipnet-width (ipn)
 378   "Return the underlying bit width of the addressing system."
 379   (ipaddr-width (ipnet-net ipn)))
 380
 381 (export 'ipnet-string)
 382 (defun ipnet-string (ipn)
 383   "Convert IPN to a string."
 384   (with-ipnet (net nil mask) ipn
 385     (format nil "~A/~A"
 386             (ipaddr-string net)
 387             (or (ipmask-cidl-slash (ipnet-width ipn) mask)
 388                 (ipaddr-string (make-instance (class-of net) :addr mask))))))
 389
 390 (defmethod print-object ((ipn ipnet) stream)
 391   (print-unreadable-object (ipn stream :type t)
 392     (write-string (ipnet-string ipn) stream)))
 393
 394 (defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t))
 395   "Parse a subnet description from (a substring of) STR.
 396
 397    Suppose we have a parent network, with a prefix length of MAX.  The WIDTH
 398    gives the overall length of addresses of the appropriate class, i.e.,
 399    (ipaddr-width WIDTH), but in fact callers have already computed this for
 400    their own reasons.
 401
 402    Parse (the designated substring of) STR to construct the base address of a
 403    subnet.  The string should have the form BASE/MASK, where the MASK is
 404    either a literal bitmask (in the usual syntax for addresses) or an integer
 405    prefix length.  An explicit prefix length is expected to cover the entire
 406    address including the parent prefix: an error is signalled if the prefix
 407    isn't long enough to cover any of the subnet.  A mask is parsed relative
 408    to the end of the parent address, just as the subnet base address is.
 409
 410    Returns the relative base address and mask as two integer values."
 411
 412   (setf-default end (length str))
 413   (let ((sl (and slashp (position #\/ str :start start :end end))))
 414     (multiple-value-bind (addr lo hi)
 415         (parse-partial-ipaddr class str :max max
 416                               :start start :end (or sl end))
 417       (let* ((present (integer-netmask hi (- hi lo)))
 418              (mask (cond ((not sl)
 419                           present)
 420                          ((every #'digit-char-p (subseq str (1+ sl) end))
 421                           (let ((length (parse-integer str
 422                                                        :start (1+ sl)
 423                                                        :end end)))
 424                             (unless (>= length (- width max))
 425                               (error "Mask doesn't reach subnet boundary"))
 426                             (integer-netmask max (- length (- width max)))))
 427                          (t
 428                           (parse-partial-ipaddr class str :max max
 429                                                 :start (1+ sl) :end end)))))
 430         (unless (zerop (logandc2 mask present))
 431           (error "Mask selects bits not present in base address"))
 432         (values addr mask)))))
 433
 434 (defun check-subipnet (base-ipn sub-addr sub-mask)
 435   "Verify that SUB-NET/SUB-MASK is an appropriate subnet of BASE-IPN.
 436
 437    The BASE-IPN is an `ipnet'; SUB-ADDR and SUB-MASK are plain integers.  If
 438    the subnet is invalid (i.e., the subnet disagrees with its putative parent
 439    over some of the fixed address bits) then an error is signalled; otherwise
 440    return the combined base address (as an `ipaddr') and mask (as an
 441    integer)."
 442   (with-ipnet (base-net base-addr base-mask) base-ipn
 443     (let* ((common (logand base-mask sub-mask))
 444            (base-overlap (logand base-addr common))
 445            (sub-overlap (logand sub-addr common))
 446            (full-mask (logior base-mask sub-mask)))
 447       (unless (or (zerop sub-overlap) (= sub-overlap base-overlap))
 448         (error "Subnet doesn't match base network"))
 449       (values (integer-ipaddr (logand full-mask (logior base-addr sub-addr))
 450                               base-net)
 451               full-mask))))
 452
 453 (export 'string-ipnet)
 454 (defun string-ipnet (str &key (start 0) (end nil))
 455   "Parse an IP network description from the string STR.
 456
 457    A network description has the form ADDRESS/MASK, where the ADDRESS is a
 458    base address in numeric form, and the MASK is either a netmask in the same
 459    form, or an integer prefix length."
 460   (setf str (stringify str))
 461   (setf-default end (length str))
 462   (let ((addr-class (guess-address-class str :start start :end end)))
 463     (multiple-value-bind (addr mask)
 464         (let ((width (ipaddr-width addr-class)))
 465           (parse-subnet addr-class width width str
 466                         :start start :end end))
 467       (make-ipnet (make-instance addr-class :addr addr)
 468                   (make-instance addr-class :addr mask)))))
 469
 470 (defun parse-subipnet (ipn str &key (start 0) (end nil) (slashp t))
 471   "Parse STR as a subnet of IPN.
 472
 473    This is mostly a convenience interface over `parse-subnet'; we compute
 474    various of the parameters from IPN rather than requiring them to be passed
 475    in explicitly.
 476
 477    Returns two values: the combined base address, as an `ipnaddr' and
 478    combined mask, as an integer."
 479
 480   (let* ((addr-class (extract-class-name (ipnet-net ipn)))
 481          (width (ipaddr-width addr-class))
 482          (max (- width
 483                  (or (ipmask-cidl-slash width (ipnet-mask ipn))
 484                      (error "Base network has complex netmask")))))
 485     (multiple-value-bind (addr mask)
 486         (parse-subnet addr-class width max (stringify str)
 487                       :start start :end end :slashp slashp)
 488       (check-subipnet ipn addr mask))))
 489
 490 (export 'string-subipnet)
 491 (defun string-subipnet (ipn str &key (start 0) (end nil))
 492   "Parse an IP subnet from a parent net IPN and a suffix string STR.
 493
 494    The (substring of) STR is expected to have the form ADDRESS/MASK, where
 495    ADDRESS is a relative subnet base address, and MASK is either a relative
 496    subnet mask or a (full) prefix length.  Returns the resulting ipnet.  If
 497    the relative base address overlaps with the existing subnet (because the
 498    base network's prefix length doesn't cover a whole number of components),
 499    then the subnet base must either agree in the overlapping portion with the
 500    parent base address or be zero.
 501
 502    For example, if IPN is the network 172.29.0.0/16, then `199/24' or
 503    `199/255' both designate the subnet 172.29.199.0/24.  Similarly, starting
 504    from 2001:ba8:1d9:8000::/52, then `8042/ffff' and `42/64' both designate
 505    the network 2001:ba8:1d9:8042::/64."
 506
 507   (multiple-value-bind (addr mask)
 508       (parse-subipnet ipn str :start start :end end)
 509     (ipaddr-ipnet addr mask)))
 510
 511 (defun ipnet (net)
 512   "Construct an IP-network object from the given argument.
 513
 514    A number of forms are acceptable:
 515
 516      * ADDR -- a single address, equivalent to (ADDR . N).
 517      * (NET . MASK|nil) -- a single-object representation.
 518      * IPNET -- return an equivalent (`equal', not necessarily `eql')
 519        version."
 520   (typecase net
 521     (ipnet net)
 522     ((or string symbol) (string-ipnet net))
 523     (t (apply #'make-ipnet (pairify net nil)))))
 524
 525 (export 'ipnet-broadcast)
 526 (defgeneric ipnet-broadcast (ipn)
 527   (:documentation "Return the broadcast address for the network IPN.
 528
 529    Returns nil if there isn't one."))
 530
 531 (export 'ipnet-hosts)
 532 (defun ipnet-hosts (ipn)
 533   "Return the number of available addresses in network IPN."
 534   (ash 1 (- (ipnet-width ipn) (logcount (ipnet-mask ipn)))))
 535
 536 (defstruct host-map
 537   "An internal object used by `ipnet-index-host' and `ipnet-host-index'.
 538
 539    Our objective is to be able to convert between flat host indices and a
 540    possibly crazy non-flat host space.  We record the underlying IPNET for
 541    convenience, and a list of byte-specifications for the runs of zero bits
 542    in the netmask, in ascending order."
 543   ipnet
 544   bytes)
 545
 546 (export 'ipnet-host-map)
 547 (defun ipnet-host-map (ipn)
 548   "Work out how to enumerate the variable portion of IPN.
 549
 550    Returns an object which can be passed to `ipnet-index-host' and
 551    `ipnet-host-index'."
 552   (let* ((mask (ipnet-mask ipn)) (bytes nil) (i 0)
 553          (len (integer-length mask)) (width (ipnet-width ipn)))
 554     (when (logbitp i mask) (setf i (find-first-bit-transition mask i)))
 555     (loop
 556       (unless (< i len) (return))
 557       (let ((next (find-first-bit-transition mask i width)))
 558         (push (byte (- next i) i) bytes)
 559         (setf i (find-first-bit-transition mask next width))))
 560     (when (< len width) (push (byte (- width len) len) bytes))
 561     (make-host-map :ipnet ipn :bytes (nreverse bytes))))
 562
 563 (export 'ipnet-index-host)
 564 (defun ipnet-index-host (map host)
 565   "Convert a HOST index to its address."
 566   (let* ((ipn (host-map-ipnet map))
 567          (addr (logand (ipnet-addr ipn) (ipnet-mask ipn))))
 568     (dolist (byte (host-map-bytes map))
 569       (setf (ldb byte addr) host
 570             host (ash host (- (byte-size byte)))))
 571     (unless (zerop host)
 572       (error "Host index out of range."))
 573     (integer-ipaddr addr (ipnet-net ipn))))
 574
 575 (export 'ipnet-host-index)
 576 (defun ipnet-host-index (map addr)
 577   "Convert an ADDR into a host index."
 578   (let ((addr (ipaddr-addr addr))
 579         (host 0) (offset 0))
 580     (dolist (byte (host-map-bytes map))
 581       (setf host (logior host
 582                          (ash (ldb byte addr) offset))
 583             offset (+ offset (byte-size byte))))
 584     host))
 585
 586 (export 'ipnet-index-bounds)
 587 (defun ipnet-index-bounds (map start end)
 588   "Return host-index bounds corresponding to the given bit-position bounds."
 589   (flet ((hack (frob-map good-byte tweak-addr)
 590            (dolist (byte (funcall frob-map (host-map-bytes map)))
 591              (let* ((low (byte-position byte))
 592                     (high (+ low (byte-size byte)))
 593                     (good (funcall good-byte low high)))
 594                (when good
 595                  (return-from hack
 596                    (ipnet-host-index map
 597                                      (ipaddr (funcall tweak-addr
 598                                                       (ash 1 good))
 599                                              (ipnet-net
 600                                               (host-map-ipnet map))))))))
 601            (error "No variable bits in range.")))
 602     (values (hack #'identity
 603                   (lambda (low high)
 604                     (and (< start high) (max start low)))
 605                   #'identity)
 606             (hack #'reverse
 607                   (lambda (low high)
 608                     (and (>= end low) (min end high)))
 609                   #'1-))))
 610
 611 (export 'ipnet-host)
 612 (defun ipnet-host (ipn host)
 613   "Return the address of the given HOST in network IPN.
 614
 615    The HOST may be a an integer index into the network (this works even with
 616    a non-contiguous netmask) or a string or symbolic suffix (as for
 617    `string-subnet')."
 618   (etypecase host
 619     (integer
 620      (ipnet-index-host (ipnet-host-map ipn) host))
 621     ((or symbol string)
 622      (multiple-value-bind (addr mask)
 623          (parse-subipnet ipn host :slashp nil)
 624        (unless (= mask (mask (ipaddr-width addr)))
 625          (error "Host address incomplete"))
 626        addr))))
 627
 628 (export 'ipaddr-networkp)
 629 (defun ipaddr-networkp (ip ipn)
 630   "Returns true if numeric address IP is within network IPN."
 631   (with-ipnet (nil addr mask) ipn
 632     (= addr (logand ip mask))))
 633
 634 (export 'ipnet-subnetp)
 635 (defun ipnet-subnetp (ipn subn)
 636   "Returns true if SUBN is a (non-strict) subnet of IPN."
 637   (with-ipnet (net addr mask) ipn
 638     (with-ipnet (subnet subaddr submask) subn
 639       (and (ipaddr-comparable-p net subnet)
 640            (= addr (logand subaddr mask))
 641            (= submask (logior mask submask))))))
 642
 643 (export 'ipnet-overlapp)
 644 (defun ipnet-overlapp (ipn-a ipn-b)
 645   "Returns true if IPN-A and IPN-B have any addresses in common."
 646   (with-ipnet (net-a addr-a mask-a) ipn-a
 647     (with-ipnet (net-b addr-b mask-b) ipn-b
 648
 649       ;; In the case of an overlap, we explicitly construct a common
 650       ;; address.  If this fails, we know that the networks don't overlap
 651       ;; after all.
 652       (flet ((narrow (addr-a mask-a addr-b mask-b)
 653                ;; Narrow network A towards B, by setting bits in A's base
 654                ;; address towards which A is indifferent, but B is not;
 655                ;; return the resulting base address.  This address is still
 656                ;; within network A, since we only set bits to which A is
 657                ;; indifferent.
 658                (logior addr-a (logand addr-b (logandc2 mask-a mask-b)))))
 659
 660         (and (ipaddr-comparable-p net-a net-b)
 661              (= (narrow addr-a mask-a addr-b mask-b)
 662                 (narrow addr-b mask-b addr-a mask-a)))))))
 663
 664 (export 'ipnet-changeable-bits)
 665 (defun ipnet-changeable-bits (width mask)
 666   "Work out the number of changeable bits in a network, given its MASK.
 667
 668    This is a conservative estimate in the case of noncontiguous masks.  The
 669    WIDTH is the total width of an address."
 670
 671   ;; We bisect the address.  If the low-order bits are changeable then we
 672   ;; recurse on them; otherwise we look at the high-order bits.  A mask M of
 673   ;; width W is changeable if it's not all-ones, i.e., if M /= 2^W.  If the
 674   ;; top half is changeable then we don't need to look at the bottom half.
 675   (labels ((recurse (width mask offset)
 676              (if (= width 1)
 677                  (if (zerop mask) (1+ offset) offset)
 678                  (let* ((lowwidth (floor width 2))
 679                         (highwidth (- width lowwidth))
 680                         (highmask (ash mask (- lowwidth))))
 681                    (if (logbitp highwidth (1+ highmask))
 682                        (recurse lowwidth
 683                                 (logand mask (mask lowwidth))
 684                                 offset)
 685                        (recurse highwidth highmask (+ offset lowwidth)))))))
 686     (recurse width mask 0)))
 687
 688 ;;;--------------------------------------------------------------------------
 689 ;;; Domain names.
 690
 691 (export '(domain-name make-domain-name domain-name-p
 692           domain-name-labels domain-name-absolutep))
 693 (defstruct domain-name
 694   "A domain name, which is a list of labels.
 695
 696    The most significant (top-level) label is first, so they're in
 697    right-to-left order.."
 698   (labels nil :type list)
 699   (absolutep nil :type boolean))
 700
 701 (export 'quotify-label)
 702 (defun quotify-label (string)
 703   "Quote an individual label STRING, using the RFC1035 rules.
 704
 705    A string which contains only printable characters other than `.', `@',
 706    `\"', `\\', `;', `(' and `)' is returned as is.  Other strings are
 707    surrounded with quotes, and special characters (now only `\\', `\"' and
 708    unprintable things) are escaped -- printable characters are preceded by
 709    backslashes, and non-printable characters are represented as \\DDD decimal
 710    codes."
 711
 712   (if (every (lambda (ch)
 713                (and (<= 33 (char-code ch) 126)
 714                     (not (member ch '(#\. #\@ #\" #\\ #\; #\( #\))))))
 715              string)
 716       string
 717       (with-output-to-string (out)
 718         (write-char #\" out)
 719         (dotimes (i (length string))
 720           (let ((ch (char string i)))
 721             (cond ((or (eql ch #\") (eql ch #\\))
 722                    (write-char #\\ out)
 723                    (write-char ch out))
 724                   ((<= 32 (char-code ch) 126)
 725                    (write-char ch out))
 726                   (t
 727                    (format out "\\~3,'0D" (char-code ch))))))
 728         (write-char #\" out))))
 729
 730 (defun unquotify-label (string &key (start 0) (end nil))
 731   "Parse and unquote a label from the STRING.
 732
 733    Returns the parsed label, and the position of the next label."
 734
 735   (let* ((end (or end (length string)))
 736          (i start)
 737          (label (with-output-to-string (out)
 738                   (labels
 739                       ((numeric-escape-char ()
 740                          ;; We've just seen a `\', and the next character is
 741                          ;; a digit.  Read the three-digit sequence, and
 742                          ;; return the appropriate character, or nil if the
 743                          ;; sequence was invalid.
 744
 745                          (let* ((e (+ i 3))
 746                                 (code
 747                                  (and (<= e end)
 748                                       (do ((j i (1+ j))
 749                                            (a 0
 750                                               (let ((d (digit-char-p
 751                                                         (char string j))))
 752                                                 (and a d (+ (* 10 a) d)))))
 753                                           ((>= j e) a)))))
 754                            (unless (<= 0 code 255)
 755                              (error "Escape code out of range."))
 756                            (setf i e)
 757                            (and code (code-char code))))
 758
 759                        (hack-backslash ()
 760                          ;; We've just seen a `\'.  Read the next character
 761                          ;; and write it to the output stream.
 762
 763                          (let ((ch (cond ((>= i end) nil)
 764                                          ((not (digit-char-p
 765                                                 (char string i)))
 766                                           (prog1 (char string i)
 767                                             (incf i)))
 768                                          (t (numeric-escape-char)))))
 769                            (unless ch
 770                              (error "Invalid escape in label."))
 771                            (write-char ch out)))
 772
 773                        (munch (delim)
 774                          ;; Read characters until we reach an unescaped copy
 775                          ;; of DELIM, writing the unescaped versions to the
 776                          ;; output stream.  Return nil if we hit the end, or
 777                          ;; the delimiter character.
 778
 779                          (loop
 780                            (when (>= i end) (return nil))
 781                            (let ((ch (char string i)))
 782                              (incf i)
 783                              (cond ((char= ch #\\)
 784                                     (hack-backslash))
 785                                    ((char= ch delim)
 786                                     (return ch))
 787                                    (t
 788                                     (write-char ch out)))))))
 789
 790                     ;; If the label starts with a `"' then continue until we
 791                     ;; get to the next `"', which must either end the string,
 792                     ;; or be followed by a `.'.  If the label isn't quoted,
 793                     ;; then munch until the `.'.
 794                     (cond
 795                       ((and (< i end) (char= (char string i) #\"))
 796                        (incf i)
 797                        (let ((delim (munch #\")))
 798                          (unless (and delim
 799                                       (or (= i end)
 800                                           (char= (prog1 (char string i)
 801                                                    (incf i))
 802                                                  #\.)))
 803                            (error "Invalid quoting in label."))))
 804                       (t
 805                        (munch #\.)))))))
 806
 807     ;; We're done.  Phew!
 808     (when (string= label "")
 809       (error "Empty labels aren't allowed."))
 810     (values label i)))
 811
 812 (export 'parse-domain-name)
 813 (defun parse-domain-name (string &key (start 0) (end nil) absolutep)
 814   "Parse (a substring of) STRING as a possibly-relative domain name.
 815
 816    If STRING doesn't end in an unquoted `.', then it's relative (to some
 817    unspecified parent domain).  The input may be the special symbol `@' to
 818    refer to the parent itself, `.' to mean the root, or a sequence of labels
 819    separated by `.'.  The final name is returned as a `domain-name' object."
 820
 821   (let ((end (or end (length string)))
 822         (i start))
 823     (flet ((parse ()
 824              ;; Parse a sequence of labels.
 825
 826              (let ((labels nil))
 827                (loop
 828                  (unless (< i end) (return))
 829                  (multiple-value-bind (label j)
 830                      (unquotify-label string :start i :end end)
 831                    (push label labels)
 832                    (setf i j)))
 833                (unless labels
 834                  (error "Empty domain names have special notations."))
 835                (make-domain-name :labels labels :absolutep absolutep))))
 836
 837       (cond ((= (1+ i) end)
 838              ;; A single-character name.  Check for the magic things;
 839              ;; otherwise I guess it must just be short.
 840
 841              (case (char string i)
 842                (#\@ (make-domain-name :labels nil :absolutep nil))
 843                (#\. (make-domain-name :labels nil :absolutep t))
 844                (t (parse))))
 845
 846             (t
 847              ;; Something more complicated.  If the name ends with `.', but
 848              ;; not `\\.', then it must be absolute.
 849              (when (and (< i end)
 850                         (char= (char string (- end 1)) #\.)
 851                         (char/= (char string (- end 2)) #\\))
 852                (decf end)
 853                (setf absolutep t))
 854              (parse))))))
 855
 856 (defmethod print-object ((name domain-name) stream)
 857   "Print a domain NAME to a STREAM, using RFC1035 quoting rules."
 858   (let ((labels (mapcar #'quotify-label
 859                         (reverse (domain-name-labels name)))))
 860     (cond (*print-escape*
 861            (print-unreadable-object (name stream :type t)
 862              (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~@[.~]~]"
 863                      labels (domain-name-absolutep name))))
 864           (t
 865            (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~]"
 866                    labels (domain-name-absolutep name))))))
 867
 868 (export 'domain-name-concat)
 869 (defun domain-name-concat (left right)
 870   "Concatenate the LEFT and RIGHT names."
 871   (if (domain-name-absolutep left)
 872       left
 873       (make-domain-name :labels (append (domain-name-labels right)
 874                                         (domain-name-labels left))
 875                         :absolutep (domain-name-absolutep right))))
 876
 877 (export 'domain-name<)
 878 (defun domain-name< (name-a name-b)
 879   "Answer whether NAME-A precedes NAME-B in an ordering of domain names.
 880
 881    Split the names into labels, and then lexicographically compare the
 882    sequences of labels, right to left, using `natural-string<'.
 883
 884    Returns two values: whether NAME-A strictly precedes NAME-B, and whether
 885    NAME-A strictly follows NAME-B.
 886
 887    This doesn't give useful answers on relative domains unless you know what
 888    you're doing."
 889
 890   (let ((labels-a (domain-name-labels name-a))
 891         (labels-b (domain-name-labels name-b)))
 892     (loop (cond ((null labels-a)
 893                  (return (values (not (null labels-b)) (null labels-b))))
 894                 ((null labels-b)
 895                  (return (values nil t)))
 896                 (t
 897                  (multiple-value-bind (precp follp)
 898                      (natural-string< (pop labels-a) (pop labels-b))
 899                    (cond (precp (return (values t nil)))
 900                          (follp (return (values nil t))))))))))
 901
 902 (export 'root-domain)
 903 (defparameter root-domain (make-domain-name :labels nil :absolutep t)
 904   "The root domain, as a convenient object.")
 905
 906 ;;;--------------------------------------------------------------------------
 907 ;;; Reverse lookups.
 908
 909 (export 'reverse-domain-component-width)
 910 (defgeneric reverse-domain-component-width (ipaddr)
 911   (:documentation "Return the component width for splitting IPADDR."))
 912
 913 (export 'reverse-domain-component-radix)
 914 (defgeneric reverse-domain-radix (ipaddr)
 915   (:documentation "Return the radix for representing IPADDR components."))
 916
 917 (export 'reverse-domain-component-suffix)
 918 (defgeneric reverse-domain-suffix (ipaddr)
 919   (:documentation "Return the reverse-lookup domain suffix for IPADDR."))
 920
 921 (export 'reverse-domain-fragment)
 922 (defgeneric reverse-domain-fragment (ipaddr start end &key partialp)
 923   (:documentation
 924    "Return a portion of an IPADDR's reverse-resolution domain name.
 925
 926    Specifically, return the portion of the name which covers the bits of an
 927    IPADDR between bits START (inclusive) and END (exclusive).  Address
 928    components which are only partially within the given bounds are included
 929    unless PARTIALP is nil.")
 930
 931   (:method ((ipaddr ipaddr) start end &key (partialp t))
 932
 933     (let ((addr (ipaddr-addr ipaddr))
 934           (comp-width (reverse-domain-component-width ipaddr))
 935           (radix (reverse-domain-radix ipaddr)))
 936
 937       (do ((i (funcall (if partialp #'round-down #'round-up)
 938                        start comp-width)
 939               (+ i comp-width))
 940            (limit (funcall (if partialp #'round-up #'round-down)
 941                           end comp-width))
 942            (comps nil (cons (format nil "~(~vR~)" radix
 943                                     (ldb (byte comp-width i) addr))
 944                             comps)))
 945           ((>= i limit) (make-domain-name :labels comps))))))
 946
 947 (export 'reverse-domain)
 948 (defgeneric reverse-domain (ipaddr-or-ipn &optional prefix-len)
 949   (:documentation "Return a reverse-resolution domain name for IPADDR-OR-IPN.
 950
 951    If PREFIX-LEN is nil then it defaults to the length of the network's fixed
 952    prefix.")
 953
 954   (:method ((ipn ipnet) &optional prefix-len)
 955     (let* ((addr (ipnet-net ipn))
 956            (mask (ipnet-mask ipn))
 957            (width (ipaddr-width addr)))
 958       (domain-name-concat (reverse-domain-fragment
 959                            addr
 960                            (if prefix-len
 961                                (- width prefix-len)
 962                                (ipnet-changeable-bits width mask))
 963                            width
 964                            :partialp nil)
 965                           (reverse-domain-suffix addr))))
 966
 967   (:method ((addr ipaddr) &optional prefix-len)
 968     (let* ((width (ipaddr-width addr)))
 969       (reverse-domain (make-ipnet addr width)
 970                       (or prefix-len width)))))
 971
 972 ;;;--------------------------------------------------------------------------
 973 ;;; Network names and specifiers.
 974
 975 (export 'net)
 976 (export 'net-name)
 977 (export 'net-ipnets)
 978 (defclass net ()
 979   ((name :type string :initarg :name :reader net-name)
 980    (ipnets :type list :initarg :ipnets :initform nil :accessor net-ipnets)
 981    (next :type unsigned-byte :initform 1 :accessor net-next)))
 982
 983 (defmethod print-object ((net net) stream)
 984   (print-unreadable-object (net stream :type t)
 985     (format stream "~A~@[ = ~{~A~^, ~}~]"
 986             (net-name net)
 987             (mapcar #'ipnet-string (net-ipnets net)))))
 988
 989 (defvar *networks* (make-hash-table :test #'equal)
 990   "The table of known networks.")
 991
 992 (export 'net-find)
 993 (defun net-find (name)
 994   "Find a network by NAME."
 995   (gethash (string-downcase (stringify name)) *networks*))
 996 (defun (setf net-find) (net name)
 997   "Make NAME map to NET."
 998   (setf (gethash (string-downcase (stringify name)) *networks*) net))
 999
1000 (export 'net-must-find)
1001 (defun net-must-find (name)
1002   (or (net-find name)
1003       (error "Unknown network ~A." name)))
1004
1005 (defun net-ipnet (net family)
1006   (find family (net-ipnets net) :key #'ipnet-family))
1007 (defun (setf net-ipnet) (ipnet net family)
1008   (assert (eq (ipnet-family ipnet) family))
1009   (let ((ipns (net-ipnets net)))
1010     (if (find family ipns :key #'ipnet-family)
1011         (nsubstitute ipnet family ipns :key #'ipnet-family)
1012         (setf (net-ipnets net) (cons ipnet ipns)))))
1013
1014 (defun process-net-form (name addr subnets)
1015   "Unpack a net-form.
1016
1017    A net-form looks like (NAME ADDR [SUBNET ...]) where:
1018
1019      * NAME is the name for the network.
1020
1021      * ADDR is the subnet address (acceptable to `string-subipnet'); at
1022        top-level, this is a plain network address (acceptable to
1023        `string-ipnet').  Alternatively (for compatibility) the ADDR for a
1024        non-top-level network can be an integer number of addresses to
1025        allocate to this subnet; the subnet's base address is implicitly just
1026        past the previous subnet's limit address (or, for the first subnet,
1027        it's the parent network's base address).  This won't work at all well
1028        if your subnets have crazy netmasks.
1029
1030      * The SUBNETs are further net-forms, of the same form, whose addresses
1031        are interpreted relative to the parent network's address.
1032
1033    The return value is a list of items of the form (NAME . IPNET)."
1034
1035   (labels ((process-subnets (subnets parent)
1036              (let ((finger (ipnet-addr parent))
1037                    (list nil))
1038                (dolist (subnet subnets list)
1039                  (destructuring-bind (name addr &rest subs) subnet
1040                    (let ((net (etypecase addr
1041                                 (integer
1042                                  (when (or (> (count-low-zero-bits addr)
1043                                               (count-low-zero-bits finger))
1044                                            (not (zerop (logand addr
1045                                                                (1- addr)))))
1046                                    (error "Bad subnet size for ~A." name))
1047                                  (make-ipnet
1048                                   (ipaddr finger (ipnet-net parent))
1049                                   (ipaddr (- (ash 1 (ipnet-width parent))
1050                                              addr)
1051                                           (ipnet-net parent))))
1052                                 ((or string symbol)
1053                                  (string-subipnet parent addr)))))
1054
1055                      (unless (ipnet-subnetp parent net)
1056                        (error "Network `~A' (~A) falls outside parent ~A."
1057                               name (ipnet-string net) (ipnet-string parent)))
1058
1059                      (dolist (entry list nil)
1060                        (let ((ipn (cdr entry)))
1061                          (when (ipnet-overlapp ipn net)
1062                            (error "Network `~A' (~A) overlaps `~A' (~A)."
1063                                   name (ipnet-string net)
1064                                   (car entry) (ipnet-string ipn)))))
1065
1066                      (setf finger
1067                            (1+ (logior
1068                                 (ipnet-addr net)
1069                                 (logxor (ipnet-mask net)
1070                                         (1- (ash 1 (ipnet-width net)))))))
1071
1072                      (when name
1073                        (push (cons name net) list))
1074
1075                      (when subs
1076                        (setf list (nconc (process-subnets subs net)
1077                                          list)))))))))
1078
1079     (let* ((top (string-ipnet addr))
1080            (list (nreverse (process-subnets subnets top))))
1081       (when name (push (cons name top) list))
1082       list)))
1083
1084 (export 'net-create)
1085 (defun net-create (name net)
1086   "Construct a new network called NAME and add it to the map.
1087
1088    The NET describes the new network, in a form acceptable to the `ipnet'
1089    function.  A named network may have multiple addresses with different
1090    families: each `net-create' call adds a new family, or modifies the net's
1091    address in an existing family."
1092   (let ((ipn (ipnet net))
1093         (net (net-find name)))
1094     (if net
1095         (progn (setf (net-ipnet net (ipnet-family ipn)) ipn) net)
1096         (setf (net-find name)
1097               (make-instance 'net
1098                              :name (string-downcase (stringify name))
1099                              :ipnets (list ipn))))))
1100
1101 (export 'defnet)
1102 (defmacro defnet (name net &rest subnets)
1103   "Main network definition macro.
1104
1105    None of the arguments is evaluated."
1106   `(progn
1107      ,@(mapcar (lambda (item)
1108                  (let ((name (car item)) (ipn (cdr item)))
1109                    `(net-create ',name ',ipn)))
1110                (process-net-form name net subnets))
1111      ',name))
1112
1113 (defun filter-by-family (func form family)
1114   "Handle a family-switch form.
1115
1116    Here, FUNC is a function of two arguments ITEM and FAMILY.  FORM is either
1117    a list of the form ((FAMILY . ITEM) ...), or an ITEM which is directly
1118    acceptable to FUNC.  Return a list of the resulting outputs of FUNC."
1119
1120   (if (and (listp form)
1121            (every (lambda (clause)
1122                     (and (listp clause)
1123                          (family-addrclass (car clause))))
1124                   form))
1125       (mapcan (lambda (clause)
1126                 (let ((fam (car clause)))
1127                   (and (or (eq family t)
1128                            (eq family fam))
1129                        (list (funcall func (cdr clause) fam)))))
1130               form)
1131       (list (funcall func form family))))
1132
1133 (export 'net-parse-to-ipnets)
1134 (defun net-parse-to-ipnets (form &optional (family t))
1135   "Parse FORM into a list of ipnet objects.
1136
1137    The FORM can be any of the following.
1138
1139      * NAME -- a named network, established using `net-create' or `defnet'
1140
1141      * IPNET -- a network, in a form acceptable to `ipnet'
1142
1143      * ((FAMILY . FORM) ...) -- a sequence of networks, filtered by FAMILY"
1144
1145   (flet ((hack (form family)
1146            (let* ((form (if (and (consp form)
1147                                  (endp (cdr form)))
1148                             (car form)
1149                             form))
1150                   (net (net-find form))
1151                   (ipns (if net (net-ipnets net)
1152                             (list (ipnet form)))))
1153              (if (eq family t) ipns
1154                  (remove family ipns
1155                          :key #'ipnet-family
1156                          :test-not #'eq)))))
1157     (let* ((ipns (apply #'append (filter-by-family #'hack form family)))
1158            (merged (reduce (lambda (ipns ipn)
1159                              (if (find (ipnet-family ipn) ipns
1160                                        :key #'ipnet-family)
1161                                  ipns
1162                                  (cons ipn ipns)))
1163                            ipns
1164                            :initial-value nil)))
1165       (or merged (error "No matching addresses.")))))
1166
1167 (export 'net-host)
1168 (defun net-host (net-form host &optional (family t))
1169   "Return the given HOST on the NET, as an anonymous `host' object.
1170
1171    HOST may be an index (in range, of course), a suffix (as a symbol or
1172    string, as for `string-subnet'), or one of the keywords:
1173
1174    :next       next host, as by net-next-host
1175    :net        network base address
1176    :broadcast  network broadcast address
1177
1178    If FAMILY is not `t', then only return an address with that family;
1179    otherwise return all available addresses."
1180   (flet ((hosts (ipns host)
1181            (mapcar (lambda (ipn) (ipnet-host ipn host))
1182                    (if (integerp host)
1183                        (remove host ipns :key #'ipnet-hosts :test #'>=)
1184                        ipns))))
1185     (let* ((net (and (typep net-form '(or string symbol))
1186                      (net-find net-form)))
1187            (ipns (net-parse-to-ipnets net-form family))
1188            (addrs (case host
1189                     (:next
1190                      (if net
1191                          (prog1 (hosts ipns (net-next net))
1192                            (incf (net-next net)))
1193                          (error "Can't use `:next' without a named net.")))
1194                     (:net (mapcar #'ipnet-net ipns))
1195                     (:broadcast (remove nil (mapcar #'ipnet-broadcast ipns)))
1196                     (t (hosts ipns host)))))
1197       (unless addrs
1198         (error "No networks have that address."))
1199       (make-instance 'host :addrs addrs))))
1200
1201 ;;;--------------------------------------------------------------------------
1202 ;;; Host names and specifiers.
1203
1204 (export 'host)
1205 (export 'host-name)
1206 (export 'host-addrs)
1207 (defclass host ()
1208   ((name :type (or string null) :initform nil
1209          :initarg :name :reader host-name)
1210    (addrs :type list :initarg :addrs :initform nil :accessor host-addrs)))
1211
1212 (defmethod print-object ((host host) stream)
1213   (print-unreadable-object (host stream :type t)
1214     (format stream "~:[<anonymous>~;~@*~A~]~@[ = ~{~A~^, ~}~]"
1215             (host-name host)
1216             (mapcar #'ipaddr-string (host-addrs host)))))
1217
1218 (defvar *hosts* (make-hash-table :test #'equal)
1219   "The table of known hostnames.")
1220
1221 (export 'host-find)
1222 (defun host-find (name)
1223   "Find a host by NAME."
1224   (gethash (string-downcase (stringify name)) *hosts*))
1225 (defun (setf host-find) (addr name)
1226   "Make NAME map to ADDR (must be an ipaddr in integer form)."
1227   (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
1228
1229 (defun merge-addresses (addrs-a addrs-b)
1230   (append (remove-if (lambda (addr)
1231                        (member (ipaddr-family addr) addrs-b
1232                                :key #'ipaddr-family))
1233                      addrs-a)
1234           addrs-b))
1235
1236 (export 'host-parse)
1237 (defun host-parse (addr &optional (family t))
1238   "Convert the ADDR into a (possibly anonymous) `host' object.
1239
1240    The ADDR can be one of a number of different things.
1241
1242    HOST                         a host name defined using `defhost'
1243
1244    (NET INDEX)                  a particular host in a network
1245
1246    IPADDR                       an address form acceptable to `ipnet'
1247
1248    ((FAMILY . ADDR) ...)        the above, restricted to a particular address
1249                                   FAMILY (i.e., one of the keywords `:ipv4',
1250                                   etc.)"
1251
1252   (labels ((filter-addresses (addrs family)
1253              (make-instance 'host
1254                             :addrs (if (eq family t) addrs
1255                                        (remove family addrs
1256                                                :key #'ipaddr-family
1257                                                :test-not #'eq))))
1258            (host-addresses (host family)
1259              (if (eq family t) host
1260                  (filter-addresses (host-addrs host) family)))
1261            (hack (addr family)
1262              (let* ((form (listify addr))
1263                     (indic (car form))
1264                     (host (and (null (cdr form))
1265                                (host-find indic))))
1266                (cond (host
1267                       (host-addresses host family))
1268                      ((and (consp (cdr form))
1269                            (endp (cddr form)))
1270                       (net-host (car form) (cadr form) family))
1271                      (t
1272                       (filter-addresses (list (ipaddr indic)) family))))))
1273     (let* ((list (filter-by-family #'hack addr family))
1274            (host (if (and list (cdr list))
1275                      (make-instance 'host
1276                                     :addrs (reduce #'merge-addresses
1277                                                    (mapcar #'host-addrs
1278                                                            (reverse list))
1279                                                    :initial-value nil))
1280                      (car list))))
1281       (unless (host-addrs host)
1282         (error "No matching addresses."))
1283       host)))
1284
1285 (export 'host-create)
1286 (defun host-create (name addr)
1287   "Make host NAME map to ADDR (anything acceptable to `host-parse')."
1288   (let ((existing (host-find name))
1289         (new (host-parse addr)))
1290     (if (not existing)
1291         (setf (host-find name)
1292               (make-instance 'host
1293                              :name (string-downcase (stringify name))
1294                              :addrs (host-addrs new)))
1295         (progn
1296           (setf (host-addrs existing)
1297                 (merge-addresses (host-addrs existing) (host-addrs new)))
1298           existing))))
1299
1300 (export 'defhost)
1301 (defmacro defhost (name addr)
1302   "Main host definition macro.  Neither NAME nor ADDR is evaluated."
1303   `(progn
1304      (host-create ',name ',addr)
1305      ',name))
1306
1307 ;;;----- That's all, folks --------------------------------------------------