5 ;;; Network (numbering) tools
7 ;;; (c) 2006 Straylight/Edgeware
10 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
26 ;;;--------------------------------------------------------------------------
30 (:use #:common-lisp #:mdw.base #:mdw.str #: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))
44 ;;;--------------------------------------------------------------------------
48 "Return 2^N - 1: i.e., a mask of N set bits."
52 "The type of unsigned 32-bit values."
56 "The type of IP (version 4) addresses."
59 ;;;--------------------------------------------------------------------------
60 ;;; Various random utilities.
62 (defun count-low-zero-bits (n)
63 "Return the number of low-order zero bits in the integer N."
69 ;;;--------------------------------------------------------------------------
70 ;;; Simple messing with IP addresses.
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
77 (setf str (stringify str))
78 (setf-default end (length str))
79 (let ((addr 0) (noct 0))
81 (let* ((pos (position #\. str :start start :end end))
82 (i (parse-integer str :start start :end (or pos end))))
84 (error "IP address octet out of range"))
85 (setf addr (+ (* addr 256) i))
89 (setf start (1+ pos))))
91 (error "Wrong number of octets in IP address"))
94 (defun ipaddr-byte (ip n)
95 "Return byte N (from most significant downwards) of an IP address."
97 (logand #xff (ash ip (* -8 (- 3 n)))))
99 (defun ipaddr-string (ip)
100 "Transform the address IP into a string in dotted-quad form."
101 (check-type ip ipaddr)
102 (join-strings #\. (collecting ()
104 (collect (ipaddr-byte ip i))))))
107 "Answer true if IP is a valid IP address in integer form."
111 "Convert IP to an IP address. If it's an integer, return it unchanged;
112 otherwise convert by `string-ipaddr'."
115 (t (string-ipaddr ip))))
117 ;;;--------------------------------------------------------------------------
120 (defun integer-netmask (i)
121 "Given an integer I, return a netmask with its I top bits set."
122 (- (ash 1 32) (ash 1 (- 32 i))))
125 "Transform IP into a netmask. If it's a small integer then it's converted
126 by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
130 ((integer 0 32) (integer-netmask ip))
133 (defun ipmask-cidl-slash (mask)
134 "Given a netmask MASK, return an integer N such that (integer-netmask N) =
135 MASK, or nil if this is impossible."
137 (when (= mask (integer-netmask i))
140 ;;;--------------------------------------------------------------------------
141 ;;; Networks: pairing an address and netmask.
143 (defun make-ipnet (net mask)
144 "Construct an IP-network object given the NET and MASK; these are
145 transformed as though by `ipaddr' and `ipmask'."
146 (let ((net (ipaddr net))
147 (mask (ipmask mask)))
148 (cons (logand net mask) mask)))
150 (defun string-ipnet (str &key (start 0) (end nil))
151 "Parse an IP-network from the string STR."
152 (setf str (stringify str))
153 (setf-default end (length str))
154 (let ((sl (position #\/ str :start start :end end)))
156 (make-ipnet (parse-ipaddr (subseq str start sl))
157 (if (find #\. str :start (1+ sl) :end end)
158 (string-ipaddr str :start (1+ sl) :end end)
159 (integer-netmask (parse-integer str
162 (make-ipnet (parse-ipaddr (subseq str start end))
163 (integer-netmask 32)))))
166 "Construct an IP-network object from the given argument. A number of forms
169 * ADDR -- a single address (equivalent to ADDR 32)
170 * (NET . MASK|nil) -- a single-object representation.
171 * IPNET -- return an equivalent (`equal', not necessarily `eql')
173 (cond ((or (stringp net) (symbolp net)) (string-ipnet net))
174 (t (apply #'make-ipnet (pairify net 32)))))
176 (defun ipnet-net (ipn)
177 "Return the base network address of IPN."
180 (defun ipnet-mask (ipn)
181 "Return the netmask of IPN."
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
190 (let (,@(and net `((,net (ipnet-net ,tmp))))
191 ,@(and mask `((,mask (ipnet-mask ,tmp)))))
194 (defun ipnet-pretty (ipn)
195 "Convert IPN to a pretty cons-cell form."
196 (with-ipnet (net mask) ipn
197 (cons (ipaddr-string net)
198 (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
200 (defun ipnet-string (ipn)
201 "Convert IPN to a string."
202 (with-ipnet (net mask) ipn
205 (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
207 (defun ipnet-broadcast (ipn)
208 "Return the broadcast address for the network IPN."
209 (with-ipnet (net mask) ipn
210 (logior net (logxor (mask 32) mask))))
212 (defun ipnet-hosts (ipn)
213 "Return the number of available addresses in network IPN."
214 (ash 1 (- 32 (logcount (ipnet-mask ipn)))))
216 (defun ipnet-host (ipn host)
217 "Return the address of the given HOST in network IPN. This works even with
218 a non-contiguous netmask."
219 (check-type host u32)
220 (with-ipnet (net mask) ipn
221 (let ((i 0) (m 1) (a net) (h host))
224 (error "Host index ~D out of range for network ~A"
225 host (ipnet-pretty ipn)))
231 (setf a (logior a (logand m h)))
232 (setf h (logandc2 h m))))
236 (defun ipaddr-networkp (ip ipn)
237 "Returns true if address IP is within network IPN."
238 (with-ipnet (net mask) ipn
239 (= net (logand ip mask))))
241 (defun ipnet-subnetp (ipn subn)
242 "Returns true if SUBN is a (non-strict) subnet of IPN."
243 (with-ipnet (net mask) ipn
244 (with-ipnet (subnet submask) subn
245 (and (= net (logand subnet mask))
246 (= submask (logior mask submask))))))
248 (defun ipnet-changeable-bytes (mask)
249 "Answers how many low-order bytes of MASK are (entirely or partially)
250 changeable. This is used when constructing reverse zones."
252 (when (/= (ipaddr-byte mask i) 255)
255 ;;;--------------------------------------------------------------------------
258 (defun resolve-hostname (name)
259 "Resolve a hostname to an IP address using the DNS, or return nil."
260 #+cmu (let ((he (ext:lookup-host-entry name)))
261 (and he (ext:host-entry-addr he)))
262 #+clisp (let ((he (ext:resolve-host-ipaddr name)))
263 (and he (string-ipaddr (car (ext:hostent-addr-list he)))))
264 #+ecl (nth-value 2 (ext:lookup-host-entry name))
265 #-(or cmu clisp ecl) nil)
267 (defun canonify-hostname (name)
268 "Resolve a hostname to canonical form using the DNS, or return nil."
269 #+cmu (let ((he (ext:lookup-host-entry name)))
270 (and he (ext:host-entry-name he)))
271 #+clisp (let ((he (ext:resolve-host-ipaddr name)))
272 (and he (ext:hostent-name he)))
273 #+ecl (nth-value 0 (ext:lookup-host-entry name))
274 #-(or cmu clisp ecl) name)
276 ;;;--------------------------------------------------------------------------
277 ;;; Host names and specifiers.
279 (defun parse-ipaddr (addr)
280 "Convert the string ADDR into an IP address: tries all sorts of things:
282 (NET [INDEX]) index a network: NET is a network name defined by
283 defnet; INDEX is an index or one of the special
284 symbols understood by net-host, and defaults to :next
286 INTEGER an integer IP address
288 IPADDR an IP address in dotted-quad form
290 HOST a host name defined by defhost
292 DNSNAME a name string to look up in the DNS"
297 (net-host (or (net-find net)
298 (error "Network ~A not found" net))
300 ((ipaddrp addr) addr)
302 (setf addr (string-downcase (stringify addr)))
304 (and (plusp (length addr))
305 (digit-char-p (char addr 0))
306 (string-ipaddr addr))
307 (resolve-hostname (stringify addr))
308 (error "Host name ~A unresolvable" addr)))))
310 (defvar *hosts* (make-hash-table :test #'equal)
311 "The table of known hostnames.")
313 (defun host-find (name)
314 "Find a host by NAME."
315 (gethash (string-downcase (stringify name)) *hosts*))
317 (defun (setf host-find) (addr name)
318 "Make NAME map to ADDR (must be an ipaddr in integer form)."
319 (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
321 (defun host-create (name addr)
322 "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
323 (setf (host-find name) (parse-ipaddr addr)))
325 (defmacro defhost (name addr)
326 "Main host definition macro. Neither NAME nor ADDR is evaluated."
328 (host-create ',name ',addr)
331 ;;;--------------------------------------------------------------------------
332 ;;; Network names and specifiers.
334 (defstruct (net (:predicate netp))
335 "A network structure. Slots:
337 NAME The network's name, as a string
338 IPNET The network base address and mask
339 HOSTS Number of hosts in the network
340 NEXT Index of the next unassigned host"
346 (defvar *networks* (make-hash-table :test #'equal)
347 "The table of known networks.")
349 (defun net-find (name)
350 "Find a network by NAME."
351 (gethash (string-downcase (stringify name)) *networks*))
353 (defun (setf net-find) (net name)
354 "Make NAME map to NET."
355 (setf (gethash (string-downcase (stringify name)) *networks*) net))
357 (defun net-get-as-ipnet (form)
358 "Transform FORM into an ipnet. FORM may be a network name, or something
359 acceptable to the ipnet function."
360 (let ((net (net-find form)))
361 (if net (net-ipnet net)
364 (defun process-net-form (root addr subnets)
365 "Unpack a net-form. The return value is a list of entries, each of which
366 is a list of the form (NAME ADDR MASK). The first entry is merely repeats
367 the given ROOT and ADDR arguments (unpacking ADDR into separate network
368 address and mask). The SUBNETS are then processed: they are a list of
369 items of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet,
370 NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in
371 the same form. An error is signalled if a net's subnets use up more hosts
372 than the net has to start with."
373 (labels ((frob (subnets limit finger)
375 (destructuring-bind (name size &rest subs) (car subnets)
376 (when (> (count-low-zero-bits size)
377 (count-low-zero-bits finger))
378 (error "Bad subnet size for ~A." name))
379 (when (> (+ finger size) limit)
380 (error "Subnet ~A out of range." name))
382 (list (list name finger (- (ash 1 32) size))))
383 (frob subs (+ finger size) finger)
384 (frob (cdr subnets) limit (+ finger size)))))))
385 (let ((ipn (ipnet addr)))
386 (with-ipnet (net mask) ipn
387 (unless (ipmask-cidl-slash mask)
388 (error "Bad mask for subnet form."))
389 (cons (list root net mask)
390 (frob subnets (+ net (ipnet-hosts ipn) 1) net))))))
392 (defun net-create (name net)
393 "Construct a new network called NAME and add it to the map. The ARGS
394 describe the new network, in a form acceptable to the ipnet function."
395 (let ((ipn (ipnet net)))
396 (setf (net-find name)
397 (make-net :name (string-downcase (stringify name))
399 :hosts (ipnet-hosts ipn)
402 (defmacro defnet (name net &rest subnets)
403 "Main network definition macro. None of the arguments is evaluated."
405 ,@(loop for (name addr mask) in (process-net-form name net subnets)
406 collect `(net-create ',name '(,addr . ,mask)))
409 (defun net-next-host (net)
410 "Given a NET, return the IP address (as integer) of the next available
411 address in the network."
412 (unless (< (net-next net) (net-hosts net))
413 (error "No more hosts left in network ~A" (net-name net)))
414 (let ((next (net-next net)))
415 (incf (net-next net))
416 (net-host net next)))
418 (defun net-host (net host)
419 "Return the given HOST on the NEXT. HOST may be an index (in range, of
420 course), or one of the keywords:
422 :NEXT next host, as by net-next-host
423 :NET network base address
424 :BROADCAST network broadcast address"
426 (:next (net-next-host net))
427 (:net (ipnet-net (net-ipnet net)))
428 (:broadcast (ipnet-broadcast (net-ipnet net)))
429 (t (ipnet-host (net-ipnet net) host))))
431 ;;;----- That's all, folks --------------------------------------------------