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