Commit | Line | Data |
---|---|---|
9c44003b MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
9c44003b MW |
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. | |
7fff3797 | 14 | ;;; |
9c44003b MW |
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. | |
7fff3797 | 19 | ;;; |
9c44003b MW |
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 | ||
9c44003b MW |
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 | ||
e1528fd6 | 37 | (export 'ipaddr) |
9c44003b MW |
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 | ||
e1528fd6 | 55 | (export 'string-ipaddr) |
9c44003b | 56 | (defun string-ipaddr (str &key (start 0) (end nil)) |
f4e0c48f MW |
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." | |
9c44003b | 61 | (setf str (stringify str)) |
b85ef4e4 | 62 | (setf-default end (length str)) |
9c44003b MW |
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 | ||
e1528fd6 | 78 | (export 'ipaddr-byte) |
9c44003b MW |
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 | ||
e1528fd6 | 84 | (export 'ipaddr-string) |
9c44003b MW |
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 | ||
e1528fd6 | 92 | (export 'ipaddrp) |
9c44003b MW |
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) | |
f4e0c48f MW |
98 | "Convert IP to an IP address. |
99 | ||
100 | If it's an integer, return it unchanged; otherwise convert by | |
101 | `string-ipaddr'." | |
9c44003b MW |
102 | (typecase ip |
103 | (ipaddr ip) | |
104 | (t (string-ipaddr ip)))) | |
105 | ||
106 | ;;;-------------------------------------------------------------------------- | |
107 | ;;; Netmasks. | |
108 | ||
e1528fd6 | 109 | (export 'integer-netmask) |
9c44003b MW |
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 | ||
e1528fd6 | 114 | (export 'ipmask) |
9c44003b MW |
115 | (defun ipmask (ip) |
116 | "Transform IP into a netmask. If it's a small integer then it's converted | |
2f1d381d MW |
117 | by `integer-netmask'; if nil, then all-bits-set; otherwise convert using |
118 | `ipaddr'." | |
9c44003b MW |
119 | (typecase ip |
120 | (null (mask 32)) | |
121 | ((integer 0 32) (integer-netmask ip)) | |
122 | (t (ipaddr ip)))) | |
123 | ||
e1528fd6 | 124 | (export 'ipmask-cidl-slash) |
9c44003b | 125 | (defun ipmask-cidl-slash (mask) |
f4e0c48f MW |
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." | |
9c44003b MW |
130 | (dotimes (i 33) |
131 | (when (= mask (integer-netmask i)) | |
132 | (return i)))) | |
133 | ||
134 | ;;;-------------------------------------------------------------------------- | |
135 | ;;; Networks: pairing an address and netmask. | |
136 | ||
e1528fd6 | 137 | (export 'make-ipnet) |
9c44003b MW |
138 | (defun make-ipnet (net mask) |
139 | "Construct an IP-network object given the NET and MASK; these are | |
2f1d381d | 140 | transformed as though by `ipaddr' and `ipmask'." |
9c44003b MW |
141 | (let ((net (ipaddr net)) |
142 | (mask (ipmask mask))) | |
143 | (cons (logand net mask) mask))) | |
144 | ||
e1528fd6 | 145 | (export 'string-ipnet) |
9c44003b MW |
146 | (defun string-ipnet (str &key (start 0) (end nil)) |
147 | "Parse an IP-network from the string STR." | |
148 | (setf str (stringify str)) | |
b85ef4e4 | 149 | (setf-default end (length str)) |
9c44003b MW |
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 | ||
e1528fd6 | 161 | (export 'ipnet) |
9c44003b | 162 | (defun ipnet (net) |
2f1d381d MW |
163 | "Construct an IP-network object from the given argument. A number of forms |
164 | are acceptable: | |
9c44003b | 165 | |
2f1d381d MW |
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." | |
9c44003b MW |
170 | (cond ((or (stringp net) (symbolp net)) (string-ipnet net)) |
171 | (t (apply #'make-ipnet (pairify net 32))))) | |
172 | ||
e1528fd6 | 173 | (export 'ipnet-net) |
9c44003b MW |
174 | (defun ipnet-net (ipn) |
175 | "Return the base network address of IPN." | |
176 | (car ipn)) | |
177 | ||
e1528fd6 | 178 | (export 'ipnet-mask) |
9c44003b MW |
179 | (defun ipnet-mask (ipn) |
180 | "Return the netmask of IPN." | |
181 | (cdr ipn)) | |
182 | ||
e1528fd6 | 183 | (export 'with-ipnet) |
9c44003b | 184 | (defmacro with-ipnet ((net mask) ipn &body body) |
f4e0c48f MW |
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." | |
9c44003b MW |
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 | ||
e1528fd6 | 196 | (export 'ipnet-pretty) |
9c44003b MW |
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 | ||
e1528fd6 | 203 | (export 'ipnet-string) |
9c44003b MW |
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 | ||
e1528fd6 | 211 | (export 'ipnet-broadcast) |
9c44003b MW |
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 | ||
e1528fd6 | 217 | (export 'ipnet-hosts) |
9c44003b MW |
218 | (defun ipnet-hosts (ipn) |
219 | "Return the number of available addresses in network IPN." | |
220 | (ash 1 (- 32 (logcount (ipnet-mask ipn))))) | |
221 | ||
e1528fd6 | 222 | (export 'ipnet-host) |
9c44003b | 223 | (defun ipnet-host (ipn host) |
f4e0c48f MW |
224 | "Return the address of the given HOST in network IPN. |
225 | ||
226 | This works even with a non-contiguous netmask." | |
9c44003b MW |
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 | ||
e1528fd6 | 244 | (export 'ipaddr-networkp) |
9c44003b MW |
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 | ||
e1528fd6 | 250 | (export 'ipnet-subnetp) |
9c44003b MW |
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 | ||
e1528fd6 | 258 | (export 'ipnet-changeable-bytes) |
9c44003b MW |
259 | (defun ipnet-changeable-bytes (mask) |
260 | "Answers how many low-order bytes of MASK are (entirely or partially) | |
2f1d381d | 261 | changeable. This is used when constructing reverse zones." |
9c44003b MW |
262 | (dotimes (i 4 4) |
263 | (when (/= (ipaddr-byte mask i) 255) | |
264 | (return (- 4 i))))) | |
265 | ||
266 | ;;;-------------------------------------------------------------------------- | |
9c44003b MW |
267 | ;;; Host names and specifiers. |
268 | ||
e1528fd6 | 269 | (export 'parse-ipaddr) |
9c44003b | 270 | (defun parse-ipaddr (addr) |
f4e0c48f MW |
271 | "Convert the string ADDR into an IP address. |
272 | ||
273 | Tries all sorts of things: | |
9c44003b | 274 | |
2f1d381d MW |
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" | |
9c44003b MW |
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 | ||
e1528fd6 | 306 | (export 'host-find) |
9c44003b MW |
307 | (defun host-find (name) |
308 | "Find a host by NAME." | |
309 | (gethash (string-downcase (stringify name)) *hosts*)) | |
9c44003b MW |
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 | ||
e1528fd6 | 314 | (export 'host-create) |
9c44003b MW |
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 | ||
e1528fd6 | 319 | (export 'defhost) |
9c44003b MW |
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 | ||
e1528fd6 | 329 | (export 'net) |
9c44003b MW |
330 | (defstruct (net (:predicate netp)) |
331 | "A network structure. Slots: | |
332 | ||
2f1d381d MW |
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" | |
9c44003b MW |
337 | name |
338 | ipnet | |
339 | hosts | |
340 | next) | |
341 | ||
342 | (defvar *networks* (make-hash-table :test #'equal) | |
343 | "The table of known networks.") | |
344 | ||
e1528fd6 | 345 | (export 'net-find) |
9c44003b MW |
346 | (defun net-find (name) |
347 | "Find a network by NAME." | |
348 | (gethash (string-downcase (stringify name)) *networks*)) | |
9c44003b MW |
349 | (defun (setf net-find) (net name) |
350 | "Make NAME map to NET." | |
351 | (setf (gethash (string-downcase (stringify name)) *networks*) net)) | |
352 | ||
e1528fd6 | 353 | (export 'net-get-as-ipnet) |
9c44003b | 354 | (defun net-get-as-ipnet (form) |
f4e0c48f MW |
355 | "Transform FORM into an ipnet. |
356 | ||
357 | FORM may be a network name, or something acceptable to the ipnet | |
358 | function." | |
9c44003b MW |
359 | (let ((net (net-find form))) |
360 | (if net (net-ipnet net) | |
361 | (ipnet form)))) | |
362 | ||
363 | (defun process-net-form (root addr subnets) | |
f4e0c48f MW |
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 | ||
9c44003b MW |
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 | ||
e1528fd6 | 394 | (export 'net-create) |
9c44003b | 395 | (defun net-create (name net) |
f4e0c48f MW |
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." | |
9c44003b MW |
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 | ||
e1528fd6 | 407 | (export 'defnet) |
9c44003b | 408 | (defmacro defnet (name net &rest subnets) |
f4e0c48f MW |
409 | "Main network definition macro. |
410 | ||
411 | None of the arguments is evaluated." | |
9c44003b MW |
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 | ||
e1528fd6 | 417 | (export 'net-next-host) |
9c44003b MW |
418 | (defun net-next-host (net) |
419 | "Given a NET, return the IP address (as integer) of the next available | |
2f1d381d | 420 | address in the network." |
9c44003b MW |
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 | ||
e1528fd6 | 427 | (export 'net-host) |
9c44003b | 428 | (defun net-host (net host) |
f4e0c48f MW |
429 | "Return the given HOST on the NEXT. |
430 | ||
431 | HOST may be an index (in range, of course), or one of the keywords: | |
2f1d381d MW |
432 | |
433 | :NEXT next host, as by net-next-host | |
434 | :NET network base address | |
435 | :BROADCAST network broadcast address" | |
9c44003b MW |
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 -------------------------------------------------- |