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

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