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 ;;; Basic types.
  28
  29 (defun mask (n)
  30   "Return 2^N - 1: i.e., a mask of N set bits."
  31   (1- (ash 1 n)))
  32
  33 (deftype u32 ()
  34   "The type of unsigned 32-bit values."
  35   '(unsigned-byte 32))
  36
  37 (export 'ipaddr)
  38 (deftype ipaddr ()
  39   "The type of IP (version 4) addresses."
  40   'u32)
  41
  42 ;;;--------------------------------------------------------------------------
  43 ;;; Various random utilities.
  44
  45 (defun count-low-zero-bits (n)
  46   "Return the number of low-order zero bits in the integer N."
  47   (if (zerop n) nil
  48       (loop for i from 0
  49             until (logbitp i n)
  50             finally (return i))))
  51
  52 ;;;--------------------------------------------------------------------------
  53 ;;; Simple messing with IP addresses.
  54
  55 (export 'string-ipaddr)
  56 (defun string-ipaddr (str &key (start 0) (end nil))
  57   "Parse STR as an IP address in dotted-quad form and return the integer
  58    equivalent.  STR may be anything at all: it's converted as if by
  59    `stringify'.  The START and END arguments may be used to parse out a
  60    substring."
  61   (setf str (stringify str))
  62   (setf-default end (length str))
  63   (let ((addr 0) (noct 0))
  64     (loop
  65       (let* ((pos (position #\. str :start start :end end))
  66              (i (parse-integer str :start start :end (or pos end))))
  67         (unless (<= 0 i 256)
  68           (error "IP address octet out of range"))
  69         (setf addr (+ (* addr 256) i))
  70         (incf noct)
  71         (unless pos
  72           (return))
  73         (setf start (1+ pos))))
  74     (unless (= noct 4)
  75       (error "Wrong number of octets in IP address"))
  76     addr))
  77
  78 (export 'ipaddr-byte)
  79 (defun ipaddr-byte (ip n)
  80   "Return byte N (from most significant downwards) of an IP address."
  81   (assert (<= 0 n 3))
  82   (logand #xff (ash ip (* -8 (- 3 n)))))
  83
  84 (export 'ipaddr-string)
  85 (defun ipaddr-string (ip)
  86   "Transform the address IP into a string in dotted-quad form."
  87   (check-type ip ipaddr)
  88   (join-strings #\. (collecting ()
  89                       (dotimes (i 4)
  90                         (collect (ipaddr-byte ip i))))))
  91
  92 (export 'ipaddrp)
  93 (defun ipaddrp (ip)
  94   "Answer true if IP is a valid IP address in integer form."
  95   (typep ip 'ipaddr))
  96
  97 (defun ipaddr (ip)
  98   "Convert IP to an IP address.  If it's an integer, return it unchanged;
  99    otherwise convert by `string-ipaddr'."
 100   (typecase ip
 101     (ipaddr ip)
 102     (t (string-ipaddr ip))))
 103
 104 ;;;--------------------------------------------------------------------------
 105 ;;; Netmasks.
 106
 107 (export 'integer-netmask)
 108 (defun integer-netmask (i)
 109   "Given an integer I, return a netmask with its I top bits set."
 110   (- (ash 1 32) (ash 1 (- 32 i))))
 111
 112 (export 'ipmask)
 113 (defun ipmask (ip)
 114   "Transform IP into a netmask.  If it's a small integer then it's converted
 115    by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
 116    `ipaddr'."
 117   (typecase ip
 118     (null (mask 32))
 119     ((integer 0 32) (integer-netmask ip))
 120     (t (ipaddr ip))))
 121
 122 (export 'ipmask-cidl-slash)
 123 (defun ipmask-cidl-slash (mask)
 124   "Given a netmask MASK, return an integer N such that (integer-netmask N) =
 125    MASK, or nil if this is impossible."
 126   (dotimes (i 33)
 127     (when (= mask (integer-netmask i))
 128       (return i))))
 129
 130 ;;;--------------------------------------------------------------------------
 131 ;;; Networks: pairing an address and netmask.
 132
 133 (export 'make-ipnet)
 134 (defun make-ipnet (net mask)
 135   "Construct an IP-network object given the NET and MASK; these are
 136    transformed as though by `ipaddr' and `ipmask'."
 137   (let ((net (ipaddr net))
 138         (mask (ipmask mask)))
 139     (cons (logand net mask) mask)))
 140
 141 (export 'string-ipnet)
 142 (defun string-ipnet (str &key (start 0) (end nil))
 143   "Parse an IP-network from the string STR."
 144   (setf str (stringify str))
 145   (setf-default end (length str))
 146   (let ((sl (position #\/ str :start start :end end)))
 147     (if sl
 148         (make-ipnet (parse-ipaddr (subseq str start sl))
 149                     (if (find #\. str :start (1+ sl) :end end)
 150                         (string-ipaddr str :start (1+ sl) :end end)
 151                         (integer-netmask (parse-integer str
 152                                                         :start (1+ sl)
 153                                                         :end end))))
 154         (make-ipnet (parse-ipaddr (subseq str start end))
 155                     (integer-netmask 32)))))
 156
 157 (export 'ipnet)
 158 (defun ipnet (net)
 159   "Construct an IP-network object from the given argument.  A number of forms
 160    are acceptable:
 161
 162      * ADDR -- a single address (equivalent to ADDR 32)
 163      * (NET . MASK|nil) -- a single-object representation.
 164      * IPNET -- return an equivalent (`equal', not necessarily `eql')
 165        version."
 166   (cond ((or (stringp net) (symbolp net)) (string-ipnet net))
 167         (t (apply #'make-ipnet (pairify net 32)))))
 168
 169 (export 'ipnet-net)
 170 (defun ipnet-net (ipn)
 171   "Return the base network address of IPN."
 172   (car ipn))
 173
 174 (export 'ipnet-mask)
 175 (defun ipnet-mask (ipn)
 176   "Return the netmask of IPN."
 177   (cdr ipn))
 178
 179 (export 'with-ipnet)
 180 (defmacro with-ipnet ((net mask) ipn &body body)
 181   "Evaluate BODY with NET and MASK bound to the base address and netmask of
 182    IPN.  Either NET or MASK (or, less usefully, both) may be nil if not
 183    wanted."
 184   (with-gensyms tmp
 185     `(let ((,tmp ,ipn))
 186        (let (,@(and net `((,net (ipnet-net ,tmp))))
 187              ,@(and mask `((,mask (ipnet-mask ,tmp)))))
 188          ,@body))))
 189
 190 (export 'ipnet-pretty)
 191 (defun ipnet-pretty (ipn)
 192   "Convert IPN to a pretty cons-cell form."
 193   (with-ipnet (net mask) ipn
 194     (cons (ipaddr-string net)
 195           (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
 196
 197 (export 'ipnet-string)
 198 (defun ipnet-string (ipn)
 199   "Convert IPN to a string."
 200   (with-ipnet (net mask) ipn
 201     (format nil "~A/~A"
 202             (ipaddr-string net)
 203             (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
 204
 205 (export 'ipnet-broadcast)
 206 (defun ipnet-broadcast (ipn)
 207   "Return the broadcast address for the network IPN."
 208   (with-ipnet (net mask) ipn
 209     (logior net (logxor (mask 32) mask))))
 210
 211 (export 'ipnet-hosts)
 212 (defun ipnet-hosts (ipn)
 213   "Return the number of available addresses in network IPN."
 214   (ash 1 (- 32 (logcount (ipnet-mask ipn)))))
 215
 216 (export 'ipnet-host)
 217 (defun ipnet-host (ipn host)
 218   "Return the address of the given HOST in network IPN.  This works even with
 219    a non-contiguous netmask."
 220   (check-type host u32)
 221   (with-ipnet (net mask) ipn
 222     (let ((i 0) (m 1) (a net) (h host))
 223       (loop
 224         (when (>= i 32)
 225           (error "Host index ~D out of range for network ~A"
 226                  host (ipnet-pretty ipn)))
 227         (cond ((zerop h)
 228                (return a))
 229               ((logbitp i mask)
 230                (setf h (ash h 1)))
 231               (t
 232                (setf a (logior a (logand m h)))
 233                (setf h (logandc2 h m))))
 234         (setf m (ash m 1))
 235         (incf i)))))
 236
 237 (export 'ipaddr-networkp)
 238 (defun ipaddr-networkp (ip ipn)
 239   "Returns true if address IP is within network IPN."
 240   (with-ipnet (net mask) ipn
 241     (= net (logand ip mask))))
 242
 243 (export 'ipnet-subnetp)
 244 (defun ipnet-subnetp (ipn subn)
 245   "Returns true if SUBN is a (non-strict) subnet of IPN."
 246   (with-ipnet (net mask) ipn
 247     (with-ipnet (subnet submask) subn
 248       (and (= net (logand subnet mask))
 249            (= submask (logior mask submask))))))
 250
 251 (export 'ipnet-changeable-bytes)
 252 (defun ipnet-changeable-bytes (mask)
 253   "Answers how many low-order bytes of MASK are (entirely or partially)
 254    changeable.  This is used when constructing reverse zones."
 255   (dotimes (i 4 4)
 256     (when (/= (ipaddr-byte mask i) 255)
 257       (return (- 4 i)))))
 258
 259 ;;;--------------------------------------------------------------------------
 260 ;;; Host names and specifiers.
 261
 262 (export 'parse-ipaddr)
 263 (defun parse-ipaddr (addr)
 264   "Convert the string ADDR into an IP address: tries all sorts of things:
 265
 266    (NET [INDEX])        index a network: NET is a network name defined by
 267                         defnet; INDEX is an index or one of the special
 268                         symbols understood by net-host, and defaults to :next
 269
 270    INTEGER              an integer IP address
 271
 272    IPADDR               an IP address in dotted-quad form
 273
 274    HOST                 a host name defined by defhost
 275
 276    DNSNAME              a name string to look up in the DNS"
 277   (cond ((listp addr)
 278          (destructuring-bind
 279              (net host)
 280              (pairify addr :next)
 281            (net-host (or (net-find net)
 282                          (error "Network ~A not found" net))
 283                      host)))
 284         ((ipaddrp addr) addr)
 285         (t
 286          (setf addr (string-downcase (stringify addr)))
 287          (or (host-find addr)
 288              (and (plusp (length addr))
 289                   (digit-char-p (char addr 0))
 290                   (string-ipaddr addr))
 291              (resolve-hostname (stringify addr))
 292              (error "Host name ~A unresolvable" addr)))))
 293
 294 (defvar *hosts* (make-hash-table :test #'equal)
 295   "The table of known hostnames.")
 296
 297 (export 'host-find)
 298 (defun host-find (name)
 299   "Find a host by NAME."
 300   (gethash (string-downcase (stringify name)) *hosts*))
 301 (defun (setf host-find) (addr name)
 302   "Make NAME map to ADDR (must be an ipaddr in integer form)."
 303   (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
 304
 305 (export 'host-create)
 306 (defun host-create (name addr)
 307   "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
 308   (setf (host-find name) (parse-ipaddr addr)))
 309
 310 (export 'defhost)
 311 (defmacro defhost (name addr)
 312   "Main host definition macro.  Neither NAME nor ADDR is evaluated."
 313   `(progn
 314      (host-create ',name ',addr)
 315      ',name))
 316
 317 ;;;--------------------------------------------------------------------------
 318 ;;; Network names and specifiers.
 319
 320 (export 'net)
 321 (defstruct (net (:predicate netp))
 322   "A network structure.  Slots:
 323
 324    NAME       The network's name, as a string
 325    IPNET      The network base address and mask
 326    HOSTS      Number of hosts in the network
 327    NEXT       Index of the next unassigned host"
 328   name
 329   ipnet
 330   hosts
 331   next)
 332
 333 (defvar *networks* (make-hash-table :test #'equal)
 334   "The table of known networks.")
 335
 336 (export 'net-find)
 337 (defun net-find (name)
 338   "Find a network by NAME."
 339   (gethash (string-downcase (stringify name)) *networks*))
 340 (defun (setf net-find) (net name)
 341   "Make NAME map to NET."
 342   (setf (gethash (string-downcase (stringify name)) *networks*) net))
 343
 344 (export 'net-get-as-ipnet)
 345 (defun net-get-as-ipnet (form)
 346   "Transform FORM into an ipnet.  FORM may be a network name, or something
 347 acceptable to the ipnet function."
 348   (let ((net (net-find form)))
 349     (if net (net-ipnet net)
 350         (ipnet form))))
 351
 352 (defun process-net-form (root addr subnets)
 353   "Unpack a net-form.  The return value is a list of entries, each of which
 354    is a list of the form (NAME ADDR MASK).  The first entry is merely repeats
 355    the given ROOT and ADDR arguments (unpacking ADDR into separate network
 356    address and mask).  The SUBNETS are then processed: they are a list of
 357    items of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet,
 358    NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in
 359    the same form.  An error is signalled if a net's subnets use up more hosts
 360    than the net has to start with."
 361   (labels ((frob (subnets limit finger)
 362              (when subnets
 363                (destructuring-bind (name size &rest subs) (car subnets)
 364                  (when (> (count-low-zero-bits size)
 365                           (count-low-zero-bits finger))
 366                    (error "Bad subnet size for ~A." name))
 367                  (when (> (+ finger size) limit)
 368                    (error "Subnet ~A out of range." name))
 369                  (append (and name
 370                               (list (list name finger (- (ash 1 32) size))))
 371                          (frob subs (+ finger size) finger)
 372                          (frob (cdr subnets) limit (+ finger size)))))))
 373     (let ((ipn (ipnet addr)))
 374       (with-ipnet (net mask) ipn
 375         (unless (ipmask-cidl-slash mask)
 376           (error "Bad mask for subnet form."))
 377         (cons (list root net mask)
 378               (frob subnets (+ net (ipnet-hosts ipn) 1) net))))))
 379
 380 (export 'net-create)
 381 (defun net-create (name net)
 382   "Construct a new network called NAME and add it to the map.  The ARGS
 383    describe the new network, in a form acceptable to the ipnet function."
 384   (let ((ipn (ipnet net)))
 385     (setf (net-find name)
 386           (make-net :name (string-downcase (stringify name))
 387                     :ipnet ipn
 388                     :hosts (ipnet-hosts ipn)
 389                     :next 1))))
 390
 391 (export 'defnet)
 392 (defmacro defnet (name net &rest subnets)
 393   "Main network definition macro.  None of the arguments is evaluated."
 394   `(progn
 395     ,@(loop for (name addr mask) in (process-net-form name net subnets)
 396             collect `(net-create ',name '(,addr . ,mask)))
 397     ',name))
 398
 399 (export 'net-next-host)
 400 (defun net-next-host (net)
 401   "Given a NET, return the IP address (as integer) of the next available
 402    address in the network."
 403   (unless (< (net-next net) (net-hosts net))
 404     (error "No more hosts left in network ~A" (net-name net)))
 405   (let ((next (net-next net)))
 406     (incf (net-next net))
 407     (net-host net next)))
 408
 409 (export 'net-host)
 410 (defun net-host (net host)
 411   "Return the given HOST on the NEXT.  HOST may be an index (in range, of
 412    course), or one of the keywords:
 413
 414    :NEXT       next host, as by net-next-host
 415    :NET        network base address
 416    :BROADCAST  network broadcast address"
 417   (case host
 418     (:next (net-next-host net))
 419     (:net (ipnet-net (net-ipnet net)))
 420     (:broadcast (ipnet-broadcast (net-ipnet net)))
 421     (t (ipnet-host (net-ipnet net) host))))
 422
 423 ;;;----- That's all, folks --------------------------------------------------