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