Upgrade everything for SBCL.

[zone] / net.lisp

;;; -*-lisp-*-
;;;
;;; Network (numbering) tools
;;;
;;; (c) 2006 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

;;;--------------------------------------------------------------------------
;;; Packaging.

(defpackage #:net
  (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:net-sys)
  (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp
	   #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet
	     #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet
	     #:ipnet-pretty #:ipnet-string #:ipnet-broadcast #:ipnet-hosts
	     #:ipnet-host #:ipaddr-networkp #:ipnet-subnetp
	     #:ipnet-changeable-bytes
	   #:host-find #:host-create #:defhost #:parse-ipaddr
	     #:resolve-hostname #:canonify-hostname
	     #:net #:net-find #:net-get-as-ipnet #:net-create #:defnet
	     #:net-next-host #:net-host))

(in-package #:net)

;;;--------------------------------------------------------------------------
;;; Basic types.

(defun mask (n)
  "Return 2^N - 1: i.e., a mask of N set bits."
  (1- (ash 1 n)))

(deftype u32 ()
  "The type of unsigned 32-bit values."
  '(unsigned-byte 32))

(deftype ipaddr ()
  "The type of IP (version 4) addresses."
  'u32)

;;;--------------------------------------------------------------------------
;;; Various random utilities.

(defun count-low-zero-bits (n)
  "Return the number of low-order zero bits in the integer N."
  (if (zerop n) nil
      (loop for i from 0
	    until (logbitp i n)
	    finally (return i))))

;;;--------------------------------------------------------------------------
;;; Simple messing with IP addresses.

(defun string-ipaddr (str &key (start 0) (end nil))
  "Parse STR as an IP address in dotted-quad form and return the integer
   equivalent.  STR may be anything at all: it's converted as if by
   `stringify'.  The START and END arguments may be used to parse out a
   substring."
  (setf str (stringify str))
  (setf-default end (length str))
  (let ((addr 0) (noct 0))
    (loop
      (let* ((pos (position #\. str :start start :end end))
	     (i (parse-integer str :start start :end (or pos end))))
	(unless (<= 0 i 256)
	  (error "IP address octet out of range"))
	(setf addr (+ (* addr 256) i))
	(incf noct)
	(unless pos
	  (return))
	(setf start (1+ pos))))
    (unless (= noct 4)
      (error "Wrong number of octets in IP address"))
    addr))

(defun ipaddr-byte (ip n)
  "Return byte N (from most significant downwards) of an IP address."
  (assert (<= 0 n 3))
  (logand #xff (ash ip (* -8 (- 3 n)))))

(defun ipaddr-string (ip)
  "Transform the address IP into a string in dotted-quad form."
  (check-type ip ipaddr)
  (join-strings #\. (collecting ()
		      (dotimes (i 4)
			(collect (ipaddr-byte ip i))))))

(defun ipaddrp (ip)
  "Answer true if IP is a valid IP address in integer form."
  (typep ip 'ipaddr))

(defun ipaddr (ip)
  "Convert IP to an IP address.  If it's an integer, return it unchanged;
   otherwise convert by `string-ipaddr'."
  (typecase ip
    (ipaddr ip)
    (t (string-ipaddr ip))))

;;;--------------------------------------------------------------------------
;;; Netmasks.

(defun integer-netmask (i)
  "Given an integer I, return a netmask with its I top bits set."
  (- (ash 1 32) (ash 1 (- 32 i))))

(defun ipmask (ip)
  "Transform IP into a netmask.  If it's a small integer then it's converted
   by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
   `ipaddr'."
  (typecase ip
    (null (mask 32))
    ((integer 0 32) (integer-netmask ip))
    (t (ipaddr ip))))

(defun ipmask-cidl-slash (mask)
  "Given a netmask MASK, return an integer N such that (integer-netmask N) =
   MASK, or nil if this is impossible."
  (dotimes (i 33)
    (when (= mask (integer-netmask i))
      (return i))))

;;;--------------------------------------------------------------------------
;;; Networks: pairing an address and netmask.

(defun make-ipnet (net mask)
  "Construct an IP-network object given the NET and MASK; these are
   transformed as though by `ipaddr' and `ipmask'."
  (let ((net (ipaddr net))
	(mask (ipmask mask)))
    (cons (logand net mask) mask)))

(defun string-ipnet (str &key (start 0) (end nil))
  "Parse an IP-network from the string STR."
  (setf str (stringify str))
  (setf-default end (length str))
  (let ((sl (position #\/ str :start start :end end)))
    (if sl
	(make-ipnet (parse-ipaddr (subseq str start sl))
		    (if (find #\. str :start (1+ sl) :end end)
			(string-ipaddr str :start (1+ sl) :end end)
			(integer-netmask (parse-integer str
							:start (1+ sl)
							:end end))))
	(make-ipnet (parse-ipaddr (subseq str start end))
		    (integer-netmask 32)))))

(defun ipnet (net)
  "Construct an IP-network object from the given argument.  A number of forms
   are acceptable:

     * ADDR -- a single address (equivalent to ADDR 32)
     * (NET . MASK|nil) -- a single-object representation.
     * IPNET -- return an equivalent (`equal', not necessarily `eql')
       version."
  (cond ((or (stringp net) (symbolp net)) (string-ipnet net))
	(t (apply #'make-ipnet (pairify net 32)))))

(defun ipnet-net (ipn)
  "Return the base network address of IPN."
  (car ipn))

(defun ipnet-mask (ipn)
  "Return the netmask of IPN."
  (cdr ipn))

(defmacro with-ipnet ((net mask) ipn &body body)
  "Evaluate BODY with NET and MASK bound to the base address and netmask of
   IPN.  Either NET or MASK (or, less usefully, both) may be nil if not
   wanted."
  (with-gensyms tmp
    `(let ((,tmp ,ipn))
       (let (,@(and net `((,net (ipnet-net ,tmp))))
	     ,@(and mask `((,mask (ipnet-mask ,tmp)))))
	 ,@body))))

(defun ipnet-pretty (ipn)
  "Convert IPN to a pretty cons-cell form."
  (with-ipnet (net mask) ipn
    (cons (ipaddr-string net)
	  (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))

(defun ipnet-string (ipn)
  "Convert IPN to a string."
  (with-ipnet (net mask) ipn
    (format nil "~A/~A"
	    (ipaddr-string net)
	    (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))

(defun ipnet-broadcast (ipn)
  "Return the broadcast address for the network IPN."
  (with-ipnet (net mask) ipn
    (logior net (logxor (mask 32) mask))))

(defun ipnet-hosts (ipn)
  "Return the number of available addresses in network IPN."
  (ash 1 (- 32 (logcount (ipnet-mask ipn)))))

(defun ipnet-host (ipn host)
  "Return the address of the given HOST in network IPN.  This works even with
   a non-contiguous netmask."
  (check-type host u32)
  (with-ipnet (net mask) ipn
    (let ((i 0) (m 1) (a net) (h host))
      (loop
        (when (>= i 32)
	  (error "Host index ~D out of range for network ~A"
		 host (ipnet-pretty ipn)))
        (cond ((zerop h)
	       (return a))
	      ((logbitp i mask)
	       (setf h (ash h 1)))
	      (t
	       (setf a (logior a (logand m h)))
	       (setf h (logandc2 h m))))
	(setf m (ash m 1))
	(incf i)))))

(defun ipaddr-networkp (ip ipn)
  "Returns true if address IP is within network IPN."
  (with-ipnet (net mask) ipn
    (= net (logand ip mask))))

(defun ipnet-subnetp (ipn subn)
  "Returns true if SUBN is a (non-strict) subnet of IPN."
  (with-ipnet (net mask) ipn
    (with-ipnet (subnet submask) subn
      (and (= net (logand subnet mask))
	   (= submask (logior mask submask))))))

(defun ipnet-changeable-bytes (mask)
  "Answers how many low-order bytes of MASK are (entirely or partially)
   changeable.  This is used when constructing reverse zones."
  (dotimes (i 4 4)
    (when (/= (ipaddr-byte mask i) 255)
      (return (- 4 i)))))

;;;--------------------------------------------------------------------------
;;; Host names and specifiers.

(defun parse-ipaddr (addr)
  "Convert the string ADDR into an IP address: tries all sorts of things:

   (NET [INDEX])	index a network: NET is a network name defined by
			defnet; INDEX is an index or one of the special
			symbols understood by net-host, and defaults to :next

   INTEGER		an integer IP address

   IPADDR		an IP address in dotted-quad form

   HOST			a host name defined by defhost

   DNSNAME		a name string to look up in the DNS"
  (cond ((listp addr)
	 (destructuring-bind
	     (net host)
	     (pairify addr :next)
	   (net-host (or (net-find net)
			 (error "Network ~A not found" net))
		     host)))
	((ipaddrp addr) addr)
	(t
	 (setf addr (string-downcase (stringify addr)))
	 (or (host-find addr)
	     (and (plusp (length addr))
		  (digit-char-p (char addr 0))
		  (string-ipaddr addr))
	     (resolve-hostname (stringify addr))
	     (error "Host name ~A unresolvable" addr)))))

(defvar *hosts* (make-hash-table :test #'equal)
  "The table of known hostnames.")

(defun host-find (name)
  "Find a host by NAME."
  (gethash (string-downcase (stringify name)) *hosts*))

(defun (setf host-find) (addr name)
  "Make NAME map to ADDR (must be an ipaddr in integer form)."
  (setf (gethash (string-downcase (stringify name)) *hosts*) addr))

(defun host-create (name addr)
  "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
  (setf (host-find name) (parse-ipaddr addr)))

(defmacro defhost (name addr)
  "Main host definition macro.  Neither NAME nor ADDR is evaluated."
  `(progn
     (host-create ',name ',addr)
     ',name))

;;;--------------------------------------------------------------------------
;;; Network names and specifiers.

(defstruct (net (:predicate netp))
  "A network structure.  Slots:

   NAME       The network's name, as a string
   IPNET      The network base address and mask
   HOSTS      Number of hosts in the network
   NEXT       Index of the next unassigned host"
  name
  ipnet
  hosts
  next)

(defvar *networks* (make-hash-table :test #'equal)
  "The table of known networks.")

(defun net-find (name)
  "Find a network by NAME."
  (gethash (string-downcase (stringify name)) *networks*))

(defun (setf net-find) (net name)
  "Make NAME map to NET."
  (setf (gethash (string-downcase (stringify name)) *networks*) net))

(defun net-get-as-ipnet (form)
  "Transform FORM into an ipnet.  FORM may be a network name, or something
acceptable to the ipnet function."
  (let ((net (net-find form)))
    (if net (net-ipnet net)
	(ipnet form))))

(defun process-net-form (root addr subnets)
  "Unpack a net-form.  The return value is a list of entries, each of which
   is a list of the form (NAME ADDR MASK).  The first entry is merely repeats
   the given ROOT and ADDR arguments (unpacking ADDR into separate network
   address and mask).  The SUBNETS are then processed: they are a list of
   items of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet,
   NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in
   the same form.  An error is signalled if a net's subnets use up more hosts
   than the net has to start with."
  (labels ((frob (subnets limit finger)
	     (when subnets
	       (destructuring-bind (name size &rest subs) (car subnets)
		 (when (> (count-low-zero-bits size)
			  (count-low-zero-bits finger))
		   (error "Bad subnet size for ~A." name))
		 (when (> (+ finger size) limit)
		   (error "Subnet ~A out of range." name))
		 (append (and name
			      (list (list name finger (- (ash 1 32) size))))
			 (frob subs (+ finger size) finger)
			 (frob (cdr subnets) limit (+ finger size)))))))
    (let ((ipn (ipnet addr)))
      (with-ipnet (net mask) ipn
	(unless (ipmask-cidl-slash mask)
	  (error "Bad mask for subnet form."))
	(cons (list root net mask)
	      (frob subnets (+ net (ipnet-hosts ipn) 1) net))))))

(defun net-create (name net)
  "Construct a new network called NAME and add it to the map.  The ARGS
   describe the new network, in a form acceptable to the ipnet function."
  (let ((ipn (ipnet net)))
    (setf (net-find name)
	  (make-net :name (string-downcase (stringify name))
		    :ipnet ipn
		    :hosts (ipnet-hosts ipn)
		    :next 1))))

(defmacro defnet (name net &rest subnets)
  "Main network definition macro.  None of the arguments is evaluated."
  `(progn
    ,@(loop for (name addr mask) in (process-net-form name net subnets)
	    collect `(net-create ',name '(,addr . ,mask)))
    ',name))

(defun net-next-host (net)
  "Given a NET, return the IP address (as integer) of the next available
   address in the network."
  (unless (< (net-next net) (net-hosts net))
    (error "No more hosts left in network ~A" (net-name net)))
  (let ((next (net-next net)))
    (incf (net-next net))
    (net-host net next)))

(defun net-host (net host)
  "Return the given HOST on the NEXT.  HOST may be an index (in range, of
   course), or one of the keywords:

   :NEXT       next host, as by net-next-host
   :NET        network base address
   :BROADCAST  network broadcast address"
  (case host
    (:next (net-next-host net))
    (:net (ipnet-net (net-ipnet net)))
    (:broadcast (ipnet-broadcast (net-ipnet net)))
    (t (ipnet-host (net-ipnet net) host))))

;;;----- That's all, folks --------------------------------------------------