1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; address.lisp --- IP address classes.
5 ;;; Copyright (C) 2006-2007, Stelian Ionescu <sionescu@common-lisp.net>
7 ;;; This code is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the version 2.1 of
9 ;;; the GNU Lesser General Public License as published by
10 ;;; the Free Software Foundation, as clarified by the
11 ;;; preamble found here:
12 ;;; http://opensource.franz.com/preamble.html
14 ;;; This program is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU Lesser General
20 ;;; Public License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
22 ;;; Boston, MA 02110-1301, USA
24 (in-package :net.sockets
)
26 ;;;; Class Definitions
29 ((name :initarg
:name
:reader address-name
:type vector
))
30 (:documentation
"Base class for all socket address classes."))
32 (defclass inet-address
(address) ()
33 (:documentation
"Base class for IPv4 and IPv6 addresses."))
35 (defclass ipv4-address
(inet-address) ()
36 (:documentation
"IPv4 address. Its low-level representation
37 can be accessed as vector of type IPV4-ARRAY through the
38 ADDRESS-NAME reader."))
40 (defclass ipv6-address
(inet-address) ()
41 (:documentation
"IPv6 address. Its low-level representation
42 can be accessed as vector of type IPV6-ARRAY through the
43 ADDRESS-NAME reader."))
45 (defclass local-address
(address)
46 ((abstract :initform nil
:initarg
:abstract
47 :reader abstract-address-p
:type boolean
))
48 (:documentation
"UNIX socket address."))
50 (defmethod make-load-form ((address inet-address
) &optional env
)
51 (declare (ignore env
))
52 `(make-instance ,(class-of address
)
53 :name
,(address-name address
)))
55 (defmethod make-load-form ((address local-address
) &optional env
)
56 (declare (ignore env
))
57 `(make-instance ,(class-of address
)
58 :name
,(address-name address
)
59 :abstrace
,(abstract-address-p address
)))
61 ;;;; Conversion functions for SOCKADDR_* structs
63 (defun sockaddr-in->sockaddr
(sin)
64 (with-foreign-slots ((addr port
) sin sockaddr-in
)
65 (values (make-instance 'ipv4-address
66 :name
(integer-to-vector (ntohl addr
)))
69 (defun sockaddr-in6->sockaddr
(sin6)
70 (with-foreign-slots ((addr port
) sin6 sockaddr-in6
)
71 (values (make-instance 'ipv6-address
72 :name
(in6-addr-to-ipv6-array addr
))
75 (defun sockaddr-un->sockaddr
(sun)
76 (with-foreign-slots ((path) sun sockaddr-un
)
77 (let ((name (make-string (1- unix-path-max
)))
79 (cond ((zerop (mem-aref path
:uint8
0))
82 (loop :for sindex
:from
0 :below
(1- unix-path-max
)
83 :for pindex
:from
1 :below unix-path-max
84 :do
(setf (schar name sindex
)
85 (code-char (mem-aref path
:uint8 pindex
)))))
87 ;; address is in the filesystem
88 (setf name
(foreign-string-to-lisp path
))))
89 (make-instance 'local-address
91 :abstract abstract
))))
93 (defun sockaddr-storage->sockaddr
(ss)
94 (with-foreign-slots ((family) ss sockaddr-storage
)
95 (switch (family :test
#'=)
96 (af-inet (sockaddr-in->sockaddr ss
))
97 (af-inet6 (sockaddr-in6->sockaddr ss
))
98 (af-local (sockaddr-un->sockaddr ss
)))))
100 (defun sockaddr->sockaddr-storage
(ss sockaddr
&optional
(port 0))
102 (ipv4-address (make-sockaddr-in ss
(address-name sockaddr
) port
))
103 (ipv6-address (make-sockaddr-in6 ss
(address-name sockaddr
) port
))
104 (local-address (make-sockaddr-un ss
(address-name sockaddr
)))))
106 (defun sockaddr-size (ss)
107 (with-foreign-slots ((family) ss sockaddr-storage
)
108 (switch (family :test
#'=)
109 (af-inet size-of-sockaddr-in
)
110 (af-inet6 size-of-sockaddr-in6
)
111 (af-local size-of-sockaddr-un
))))
113 ;;;; Conversion functions
115 (defun integer-to-dotted (integer)
116 "Convert a 32-bit unsigned integer to a dotted string."
117 (check-type integer ub32
"an '(unsigned-byte 32)")
118 (format nil
"~A.~A.~A.~A"
119 (ldb (byte 8 24) integer
)
120 (ldb (byte 8 16) integer
)
121 (ldb (byte 8 8) integer
)
122 (ldb (byte 8 0) integer
)))
124 (defun dotted-to-vector (address)
125 "Convert a dotted IPv4 address to a (simple-array (unsigned-byte 8) 4)."
126 (check-type address string
"a string")
127 (let ((addr (make-array 4 :element-type
'ub8
:initial-element
0))
128 (split (split-sequence #\. address
:count
5)))
129 (flet ((set-array-value (index str
)
130 (setf (aref addr index
)
131 (ensure-number str
:type
'ub8
))))
132 (let ((len (length split
)))
134 (error 'parse-error
))
135 (set-array-value 3 (nth (1- len
) split
))
136 (loop :for n
:in split
137 :for index
:below
(1- len
)
138 :do
(set-array-value index n
))))
141 (defun dotted-to-integer (address)
142 "Convert a dotted IPv4 address to a 32-bit unsigned integer."
143 (vector-to-integer (dotted-to-vector address
)))
145 (defun vector-to-dotted (vector)
146 "Convert an 4-element vector to a dotted string."
147 (coercef vector
'ipv4-array
)
148 (let ((*print-pretty
* nil
))
149 (with-output-to-string (s)
150 (princ (aref vector
0) s
) (princ #\. s
)
151 (princ (aref vector
1) s
) (princ #\. s
)
152 (princ (aref vector
2) s
) (princ #\. s
)
153 (princ (aref vector
3) s
))))
155 ;;; TODO: add tests against inet_pton(). Optimize if necessary.
156 ;;; <http://java.sun.com/javase/6/docs/api/java/net/Inet6Address.html#format>
157 (defun colon-separated-to-vector (string)
158 "Convert a colon-separated IPv6 address to a (simple-array ub16 8)."
159 (check-type string string
"a string")
160 (when (< (length string
) 2)
161 (error 'parse-error
))
162 (flet ((handle-trailing-and-leading-colons (string)
164 (end (length string
))
166 (trailing-colon-p nil
)
167 (tokens-from-leading-or-trailing-zeros 0))
168 (when (char= #\
: (char string
0))
170 (unless (char= #\
: (char string
1))
172 (setq tokens-from-leading-or-trailing-zeros
1)))
173 (when (char= #\
: (char string
(- end
1)))
174 (setq trailing-colon-p t
)
175 (unless (char= #\
: (char string
(- end
2)))
176 (incf tokens-from-leading-or-trailing-zeros
))
178 (values start end start-i trailing-colon-p
179 tokens-from-leading-or-trailing-zeros
)))
181 (= 0 (length string
)))
182 ;; we need to use this instead of dotted-to-vector because
183 ;; abbreviated IPv4 addresses are invalid in this context.
184 (ipv4-string-to-ub16-list (string)
185 (let ((tokens (split-sequence #\. string
)))
186 (when (= (length tokens
) 4)
187 (let ((ipv4 (map 'vector
189 (let ((x (ignore-errors
190 (parse-integer string
))))
191 (if (or (null x
) (not (<= 0 x
#xff
)))
195 (list (dpb (aref ipv4
0) (byte 8 8) (aref ipv4
1))
196 (dpb (aref ipv4
2) (byte 8 8) (aref ipv4
3)))))))
197 (parse-hex-ub16 (string)
198 (ensure-number string
:type
'ub16
:radix
16)))
199 (multiple-value-bind (start end start-i trailing-colon-p extra-tokens
)
200 (handle-trailing-and-leading-colons string
)
201 (let* ((vector (make-array 8 :element-type
'ub16
:initial-element
0))
202 (tokens (split-sequence #\
: string
:start start
:end end
))
203 (empty-tokens (count-if #'emptyp tokens
))
204 (token-count (+ (length tokens
) extra-tokens
)))
205 (unless trailing-colon-p
206 (let ((ipv4 (ipv4-string-to-ub16-list (lastcar tokens
))))
209 (setq tokens
(nconc (butlast tokens
) ipv4
)))))
210 (when (or (> token-count
8) (> empty-tokens
1)
211 (and (zerop empty-tokens
) (/= token-count
8)))
212 (error 'parse-error
))
213 (loop for i from start-i and token in tokens do
215 ((integerp token
) (setf (aref vector i
) token
))
216 ((emptyp token
) (incf i
(- 8 token-count
)))
217 (t (setf (aref vector i
) (parse-hex-ub16 token
)))))
220 (defun ipv4-on-ipv6-mapped-vector-p (vector)
221 (and (dotimes (i 5 t
)
222 (when (plusp (aref vector i
))
224 (= (aref vector
5) #xffff
)))
226 (defun princ-ipv4-on-ipv6-mapped-address (vector s
)
228 (let ((*print-base
* 10) (*print-pretty
* nil
))
229 (princ (ldb (byte 8 8) (aref vector
6)) s
) (princ #\. s
)
230 (princ (ldb (byte 8 0) (aref vector
6)) s
) (princ #\. s
)
231 (princ (ldb (byte 8 8) (aref vector
7)) s
) (princ #\. s
)
232 (princ (ldb (byte 8 0) (aref vector
7)) s
)))
234 (defun vector-to-colon-separated (vector &optional
(case :downcase
))
235 "Convert an 8-element vector to a colon-separated IPv6
236 address. CASE may be :DOWNCASE or :UPCASE."
237 (coercef vector
'ipv6-array
)
238 (check-type case
(member :upcase
:downcase
) "either :UPCASE or :DOWNCASE")
239 (let ((s (make-string-output-stream)))
240 (flet ((find-zeros ()
241 (let ((start (position 0 vector
:start
1 :end
7)))
244 (position-if #'plusp vector
:start start
:end
7)))))
245 (princ-subvec (start end
)
246 (loop :for i
:from start
:below end
247 :do
(princ (aref vector i
) s
) (princ #\
: s
))))
249 ((ipv4-on-ipv6-mapped-vector-p vector
)
250 (princ-ipv4-on-ipv6-mapped-address vector s
))
252 (let ((*print-base
* 16) (*print-pretty
* nil
))
253 (when (plusp (aref vector
0)) (princ (aref vector
0) s
))
255 (multiple-value-bind (start end
) (find-zeros)
256 (cond (start (princ-subvec 1 start
)
258 (when end
(princ-subvec end
7)))
259 (t (princ-subvec 1 7))))
260 (when (plusp (aref vector
7)) (princ (aref vector
7) s
))))))
261 (let ((str (get-output-stream-string s
)))
263 (:downcase
(nstring-downcase str
))
264 (:upcase
(nstring-upcase str
))))))
266 (defmacro ignore-parse-errors
(&body body
)
267 ;; return first value only
268 `(values (ignore-some-conditions (parse-error) ,@body
)))
270 (defun string-address-to-vector (address)
271 "Convert a string address (dotted or colon-separated) to a vector address.
272 If the string is not a valid address, return NIL."
273 (or (ignore-parse-errors (dotted-to-vector address
))
274 (ignore-parse-errors (colon-separated-to-vector address
))))
276 (defun address-to-vector (address)
277 "Convert any representation of an internet address to a vector.
278 Allowed inputs are: unsigned 32-bit integers, strings, vectors
279 and INET-ADDRESS objects. If the address is valid, two values
280 are returned: the vector and the address type (:IPV4 or IPV6),
281 otherwise NIL is returned."
282 (let (vector addr-type
)
284 (number (and (ignore-parse-errors
285 (setf vector
(integer-to-vector address
)))
286 (setf addr-type
:ipv4
)))
288 ((ignore-parse-errors (setf vector
(dotted-to-vector address
)))
289 (setf addr-type
:ipv4
))
290 ((ignore-parse-errors
291 (setf vector
(colon-separated-to-vector address
)))
292 (setf addr-type
:ipv6
))))
293 ((vector * 4) (and (ignore-parse-errors
294 (setf vector
(coerce address
'ipv4-array
)))
295 (setf addr-type
:ipv4
)))
296 ((vector * 8) (and (ignore-parse-errors
297 (setf vector
(coerce address
'ipv6-array
)))
298 (setf addr-type
:ipv6
)))
299 (ipv4-address (setf vector
(address-name address
)
301 (ipv6-address (setf vector
(address-name address
)
304 (values vector addr-type
))))
306 (defun ensure-address (address &key
(family :internet
) (errorp t
))
307 "If FAMILY is :LOCAL, a LOCAL-ADDRESS is instantiated with
308 ADDRESS as its NAME slot. If FAMILY is :INTERNET, an appropriate
309 subtype of INET-ADDRESS is instantiated after guessing the
310 address type through ADDRESS-TO-VECTOR. If the address is invalid
311 and ERRORP is not NIL, then a CL:PARSE-ERROR is signalled,
312 otherwise NIL is returned.
314 When ADDRESS is already an instance of the ADDRESS class, a check
315 is made to see if it matches the FAMILY argument and it is
316 returned unmodified."
321 (check-type address inet-address
"an INET address")
322 (unless (typep address
'inet-address
)
323 (return-from ensure-address
)))
325 (t (let ((vector (address-to-vector address
)))
327 (vector (make-address vector
))
328 (errorp (error 'parse-error
)))))))
331 (string (make-instance 'local-address
:name address
))
333 (check-type address local-address
"a local address")
334 (unless (typep address
'local-address
)
335 (return-from ensure-address
)))
340 (defgeneric address-to-string
(address)
341 (:documentation
"Returns a textual presentation of ADDRESS."))
343 (defmethod address-to-string ((address ipv4-address
))
344 (vector-to-dotted (address-name address
)))
346 (defmethod address-to-string ((address ipv6-address
))
347 (vector-to-colon-separated (address-name address
)))
349 (defmethod address-to-string ((address local-address
))
350 (if (abstract-address-p address
)
352 (address-name address
)))
354 (defmethod print-object ((address ipv4-address
) stream
)
355 (format stream
"@~A" (address-to-string address
)))
357 (defmethod print-object ((address ipv6-address
) stream
)
358 (format stream
"@~A" (address-to-string address
)))
360 (defmethod print-object ((address local-address
) stream
)
361 (print-unreadable-object (address stream
:type nil
:identity nil
)
362 (format stream
"Unix socket address: ~A. Abstract: ~:[no~;yes~]"
363 (address-to-string address
) (abstract-address-p address
))))
367 (defun read-literal-ip-address (stream &optional c n
)
368 (declare (ignore c n
))
369 (loop :with sstr
:= (make-string-output-stream)
370 :for char
:= (read-char stream nil nil
)
372 :do
(cond ((or (digit-char-p char
16)
373 (member char
'(#\.
#\
:) :test
#'char
=))
374 (write-char char sstr
))
376 (unread-char char stream
)
378 :finally
(return (or (ensure-address (get-output-stream-string sstr
)
380 (error 'reader-error
:stream stream
)))))
382 (define-syntax ip-address
383 (set-macro-character #\
@ 'read-literal-ip-address t
))
385 ;;;; Equality Methods
387 (defun vector-equal (v1 v2
)
388 (and (= (length v1
) (length v2
))
389 (every #'eql v1 v2
)))
391 (defgeneric address
= (addr1 addr2
)
392 (:documentation
"Returns T if both arguments are the same socket address."))
394 (defmethod address= ((addr1 inet-address
) (addr2 inet-address
))
395 (vector-equal (address-name addr1
) (address-name addr2
)))
397 (defmethod address= ((addr1 local-address
) (addr2 local-address
))
398 (equal (address-name addr1
) (address-name addr2
)))
400 (defun address-equal-p (addr1 addr2
&optional
(family :internet
))
401 "Returns T if both arguments are designators for the same socket address."
402 (address= (ensure-address addr1
:family family
)
403 (ensure-address addr2
:family family
)))
407 (defgeneric copy-address
(address)
409 "Returns a copy of ADDRESS which is ADDRESS= to the original."))
411 (defmethod copy-address ((addr ipv4-address
))
412 (make-instance 'ipv4-address
:name
(copy-seq (address-name addr
))))
414 (defmethod copy-address ((addr ipv6-address
))
415 (make-instance 'ipv6-address
:name
(copy-seq (address-name addr
))))
417 (defmethod copy-address ((addr local-address
))
418 (make-instance 'local-address
419 :name
(copy-seq (address-name addr
))
420 :abstract
(abstract-address-p addr
)))
422 ;;; Returns an IPv6 address by mapping ADDR onto it.
423 (defun map-ipv4-address-to-ipv6 (address)
424 (make-instance 'ipv6-address
425 :name
(map-ipv4-vector-to-ipv6 (address-name address
))))
427 (defun map-ipv6-address-to-ipv4 (address)
428 (assert (ipv6-ipv4-mapped-p address
) (address)
429 "Not an IPv6-mapped IPv4 address: ~A" address
)
430 (make-instance 'ipv4-address
431 :name
(map-ipv6-vector-to-ipv4 (address-name address
))))
435 (defun make-address (name)
436 "Constructs an ADDRESS object. NAME should be of type
437 IPV4-ARRAY, IPV6-ARRAY or STRING in which case an instance of
438 IPV4-ADDRESS, IPV6-ADDRESS or LOCAL-ADDRESS, respectively, will
439 be created. Otherwise, a TYPE-ERROR is signalled. See also
442 ((ignore-errors (coercef name
'ipv4-array
))
443 (make-instance 'ipv4-address
:name name
))
444 ((ignore-errors (coercef name
'ipv6-array
))
445 (make-instance 'ipv6-address
:name name
))
446 ((stringp name
) (make-instance 'local-address
:name name
))
447 (t (error 'type-error
:datum name
448 :expected-type
'(or string ipv4-array ipv6-array
)))))