1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;; Copyright (C) 2006, 2007 Stelian Ionescu
5 ;; This code is free software; you can redistribute it and/or
6 ;; modify it under the terms of the version 2.1 of
7 ;; the GNU Lesser General Public License as published by
8 ;; the Free Software Foundation, as clarified by the
9 ;; preamble found here:
10 ;; http://opensource.franz.com/preamble.html
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU Lesser General
18 ;; Public License along with this library; if not, write to the
19 ;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
20 ;; Boston, MA 02110-1301, USA
22 (in-package :net.sockets
)
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;;; RESOLVER CONDITIONS ;;;
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (define-constant +resolver-error-map
+
31 `((:eai-again . resolver-again-error
)
32 (:eai-fail . resolver-fail-error
)
33 (:eai-noname . resolver-no-name-error
)
34 (:eai-nodata . resolver-no-name-error
)
35 (:eai-addrfamily . resolver-no-name-error
)
36 (:eai-service . resolver-no-service-error
)))
38 (defun resolver-error-condition (id)
39 (cdr (assoc id
+resolver-error-map
+)))
41 (defmacro resolver-error-code
(id)
44 (define-condition resolver-error
(system-error)
45 ((data :initarg
:data
:reader resolver-error-data
))
46 (:documentation
"Signaled when an error occurs while trying to resolve an address."))
48 (defmacro define-resolver-error
(name code identifier format-string
&optional documentation
)
51 (define-condition ,name
(resolver-error)
52 ((code :initform
,code
)
53 (identifier :initform
,identifier
))
54 (:report
(lambda (condition stream
)
55 (format stream
,format-string
(resolver-error-data condition
))
56 (print-message-if-not-null condition stream
)))
57 (:documentation
,documentation
))))
59 (define-resolver-error resolver-again-error
(resolver-error-code :eai-again
) :resolver-again
60 "Temporary failure occurred while resolving: ~S"
61 "Condition signaled when a temporary failure occurred.")
63 (define-resolver-error resolver-fail-error
(resolver-error-code :eai-fail
) :resolver-fail
64 "Non recoverable error occurred while resolving: ~S"
65 "Condition signaled when a non-recoverable error occurred.")
67 (define-resolver-error resolver-no-name-error
(resolver-error-code :eai-noname
) :resolver-no-name
68 "Host or service not found: ~S"
69 "Condition signaled when a host or service was not found.")
71 (define-resolver-error resolver-no-service-error
(resolver-error-code :eai-service
) :resolver-no-service
72 "Service not found for specific socket type: ~S"
73 "Condition signaled when a service was not found for the socket type requested.")
75 (define-resolver-error resolver-unknown-error
0 :resolver-unknown
76 "Unknown error while resolving: ~S"
77 "Condition signaled when an unknown error is signaled while resolving an address.")
79 (defun resolver-error (identifier &key data message
)
80 (let ((condition-class
81 (resolver-error-condition identifier
)))
83 (error condition-class
84 :code
(resolver-error-code identifier
)
85 :identifier identifier
88 (error 'resolver-unknown-error
89 :code
(or (ignore-errors
90 (resolver-error-code identifier
))
92 :identifier identifier
96 (define-constant +max-ipv4-value
+ (1- (expt 2 32)))
107 (defun get-address-info (&key
(node (null-pointer)) (service (null-pointer))
108 (hint-flags 0) (hint-family 0)
109 (hint-type 0) (hint-protocol 0))
110 (with-foreign-objects ((hints 'et
:addrinfo
)
112 (et:bzero hints et
:size-of-addrinfo
)
113 (with-foreign-slots ((et:flags et
:family et
:socktype et
:protocol
)
115 (setf et
:flags hint-flags
116 et
:family hint-family
117 et
:socktype hint-type
118 et
:protocol hint-protocol
)
119 (et:getaddrinfo node service hints res
)
120 (make-pointer (pointer-address (mem-ref res
:pointer
))))))
122 (defun get-name-info (sockaddr &key
(want-host t
) want-service
(flags 0))
123 (assert (or want-host want-service
))
124 (let ((salen et
:size-of-sockaddr-storage
))
125 (with-foreign-objects ((host :char et
:ni-maxhost
)
126 (service :char et
:ni-maxserv
))
127 (et:getnameinfo sockaddr salen
128 host
(if want-host et
:ni-maxhost
0)
129 service
(if want-service et
:ni-maxserv
0)
131 (values (and want-host
(foreign-string-to-lisp host et
:ni-maxhost
))
132 (and want-service
(foreign-string-to-lisp service et
:ni-maxserv
))))))
135 ((truename :initarg
:truename
:reader host-truename
)
136 (aliases :initarg
:aliases
:reader host-aliases
)
137 (addresses :initarg
:addresses
:reader host-addresses
)))
139 (defmethod initialize-instance :after
((host host
) &key
)
140 (with-slots (addresses) host
141 (unless (consp addresses
)
142 (setf addresses
(list addresses
)))))
144 (defgeneric random-address
(host))
145 (defmethod random-address ((host host
))
146 (with-slots (addresses) host
147 (nth (random (length addresses
))
150 (defun make-host (truename addresses
&optional aliases
)
154 :addresses addresses
))
156 (defmethod print-object ((host host
) stream
)
157 (print-unreadable-object (host stream
:type t
:identity nil
)
158 (with-slots (truename aliases addresses
) host
159 (format stream
"Cannonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~].~%Addresses: ~{~A~^, ~}"
160 truename aliases addresses
))))
164 ;; Auxiliary functions
167 (defun lookup-host-u8-vector-4 (host ipv6
)
168 (coercef host
'ub8-sarray
)
172 (with-foreign-object (sin 'et
:sockaddr-storage
)
173 (make-sockaddr-in sin host
)
174 (return-from lookup-host-u8-vector-4
175 (make-host (get-name-info sin
:flags et
:ni-namereqd
)
176 (list (make-address (copy-seq host
)))))))
178 (with-foreign-object (sin6 'et
:sockaddr-storage
)
179 (let ((ipv6addr (map-ipv4-vector-to-ipv6 host
)))
180 (make-sockaddr-in6 sin6 ipv6addr
)
181 (return-from lookup-host-u8-vector-4
182 (make-host (get-name-info sin6
:flags et
:ni-namereqd
)
183 (list (make-address ipv6addr
)))))))
185 (resolver-error :eai-fail
187 :message
"Received IPv4 address but IPv6-only was requested.")))
188 (et:resolv-error
(err)
189 (resolver-error (et:system-error-identifier err
) :data host
))))
191 (defun lookup-host-u16-vector-8 (host ipv6
)
192 (coercef host
'ub16-sarray
)
196 (resolver-error :eai-fail
198 :message
"Received IPv6 address but IPv4-only was requested."))
200 (with-foreign-object (sin6 'et
:sockaddr-storage
)
201 (make-sockaddr-in6 sin6 host
)
202 (return-from lookup-host-u16-vector-8
203 (make-host (get-name-info sin6
:flags et
:ni-namereqd
)
204 (list (make-address (copy-seq host
))))))))
205 (et:resolv-error
(err)
206 (resolver-error (et:system-error-identifier err
) :data host
))))
208 (defun make-host-from-addrinfo (addrinfo)
209 (let ((canonname (foreign-slot-value addrinfo
'et
:addrinfo
'et
:canonname
))
212 :for addrptr
:= addrinfo
213 :then
(foreign-slot-value addrptr
'et
:addrinfo
'et
:next
)
214 :while
(not (null-pointer-p addrptr
))
215 :collect
(sockaddr-storage->sockaddr
216 (foreign-slot-value addrptr
'et
:addrinfo
'et
:addr
)))))
217 (make-host (if (null-pointer-p canonname
)
219 (foreign-string-to-lisp canonname
))
222 (defun map-host-ipv4-addresses-to-ipv6 (hostobj)
223 (declare (type host hostobj
))
224 (with-slots (addresses) hostobj
226 (mapcar #'(lambda (address)
227 (if (ipv4-address-p address
)
228 (make-address (map-ipv4-vector-to-ipv6 (name address
)))
235 ;; External interface
238 (defgeneric lookup-host
(host &key
&allow-other-keys
))
240 (defmethod lookup-host ((host string
) &key
(ipv6 *ipv6
*))
241 (check-type ipv6
(member nil
:ipv6 t
) "valid IPv6 configuration")
242 (flet ((decide-family-and-flags ()
244 ((nil) (values et
:af-inet
0))
245 ;; freebsd 6.1 rejects AI_V4MAPPED and AI_ALL(weird thing)
246 ;; therefore I'll use AF_UNSPEC and do the mappings myself
247 ((t) #-freebsd
(values et
:af-inet6
(logior et
:ai-v4mapped et
:ai-all
))
248 #+freebsd
(values et
:af-unspec
0))
249 (:ipv6
(values et
:af-inet6
0)))))
250 (multiple-value-bind (vector type
) (address-to-vector host
)
252 (:ipv4
(return-from lookup-host
253 (lookup-host-u8-vector-4 vector ipv6
)))
254 (:ipv6
(return-from lookup-host
255 (lookup-host-u16-vector-8 vector ipv6
)))
256 (t (multiple-value-bind (family flags
)
257 (decide-family-and-flags)
258 (setf flags
(logior flags et
:ai-canonname et
:ai-addrconfig
))
261 (get-address-info :node host
264 :hint-type et
:sock-stream
265 :hint-protocol et
:ipproto-ip
))
266 (hostobj (make-host-from-addrinfo addrinfo
)))
267 (when (string-not-equal (host-truename hostobj
)
269 (setf (slot-value hostobj
'aliases
) (list host
)))
270 (et:freeaddrinfo addrinfo
)
271 ;; mapping IPv4 addresses onto IPv6
274 (map-host-ipv4-addresses-to-ipv6 hostobj
))
275 (return-from lookup-host hostobj
))
276 (et:resolv-error
(err)
277 (resolver-error (et:system-error-identifier err
) :data host
)))))))))
279 (defmethod lookup-host (host &key
(ipv6 *ipv6
*))
280 (check-type ipv6
(member nil
:ipv6 t
) "valid IPv6 configuration")
281 (multiple-value-bind (vector type
) (address-to-vector host
)
283 (:ipv4
(lookup-host-u8-vector-4 vector ipv6
))
284 (:ipv6
(lookup-host-u16-vector-8 vector ipv6
)))))
286 (defun convert-or-lookup-inet-address (address &optional
(ipv6 *ipv6
*))
287 (or (ignore-errors (ensure-address address
:internet
))
288 (let ((addresses (host-addresses (lookup-host address
:ipv6 ipv6
))))
289 (values (car addresses
)
292 ;;;;;;;;;;;;;;;;;;;;;;;
293 ;;;;;;;;;;;;;;;;;;;;;;;
295 ;;; SERVICE LOOKUP ;;;
297 ;;;;;;;;;;;;;;;;;;;;;;;
298 ;;;;;;;;;;;;;;;;;;;;;;;
301 ((name :initarg
:name
:reader service-name
)
302 (port :initarg
:port
:reader service-port
)
303 (protocol :initarg
:protocol
:reader service-protocol
)))
305 (defun make-service (name port protocol
)
306 (make-instance 'service
311 (defmethod print-object ((service service
) stream
)
312 (print-unreadable-object (service stream
:type t
:identity nil
)
313 (with-slots (name port protocol
) service
314 (format stream
"Name: ~A. Port: ~A. Protocol: ~A" name port protocol
))))
316 (defun lookup-service-number (port-number protocol
&key name-required
)
317 (declare (type ub32 port-number
))
318 (with-foreign-object (sin 'et
:sockaddr-in
)
322 (et:bzero sin et
:size-of-sockaddr-in
)
323 (with-foreign-slots ((et:family et
:port
) sin et
:sockaddr-in
)
324 (setf et
:family et
:af-inet
325 et
:port
(htons port-number
)))
333 :want-host nil
:want-service t
)))))
334 (make-service service port-number protocol
))))
336 (defun lookup-service-name (port protocol
)
337 (flet ((protocol-type-to-int (protocol)
339 (:tcp et
:sock-stream
)
342 (socket-type-from-int (alien-val)
344 (#.et
:sock-stream
:tcp
)
345 (#.et
:sock-dgram
:udp
)
348 (get-address-info :service port
349 :hint-type
(protocol-type-to-int protocol
)))
351 (ntohs (foreign-slot-value (foreign-slot-value addrinfo
'et
:addrinfo
'et
:addr
)
352 'et
:sockaddr-in
'et
:port
)))
354 (socket-type-from-int (foreign-slot-value addrinfo
'et
:addrinfo
'et
:socktype
))))
355 (et:freeaddrinfo addrinfo
)
356 (return-from lookup-service-name
357 (make-service port port-number true-protocol
)))))
359 (defun lookup-service (port &key
(protocol :tcp
) (name-required nil
))
360 (check-type protocol
(member :tcp
:udp
:any
))
361 (let ((parsed-number (parse-number-or-nil port
:ub16
)))
364 (lookup-service-number parsed-number protocol
365 :name-required name-required
)
366 (lookup-service-name port protocol
))
367 (et:resolv-error
(err)
368 (resolver-error (et:system-error-identifier err
) :data port
)))))
372 ;;;;;;;;;;;;;;;;;;;;;;;;
373 ;;;;;;;;;;;;;;;;;;;;;;;;
375 ;;; PROTOCOL LOOKUP ;;;
377 ;;;;;;;;;;;;;;;;;;;;;;;;
378 ;;;;;;;;;;;;;;;;;;;;;;;;
380 (defclass protocol
()
381 ((name :initarg
:name
:reader protocol-name
)
382 (aliases :initarg
:aliases
:reader protocol-aliases
)
383 (protonum :initarg
:protonum
:reader protocol-number
)))
385 (defun make-protocol (name protonum
&optional aliases
)
386 (make-instance 'protocol
391 (defmethod print-object ((protocol protocol
) stream
)
392 (print-unreadable-object (protocol stream
:type t
:identity nil
)
393 (with-slots (name aliases protonum
) protocol
394 (format stream
"Name: ~S. Protocol number: ~A. Aliases: ~{~S~^, ~}"
395 name protonum aliases
))))
397 (define-condition unknown-protocol
(system-error)
398 ((name :initarg
:name
:initform nil
:reader protocol-name
))
399 (:report
(lambda (condition stream
)
400 (format stream
"Unknown protocol: ~S"
401 (protocol-name condition
))))
402 (:documentation
"Condition raised when a network protocol is not found."))
404 (defun make-protocol-from-protoent (protoent)
405 (with-foreign-slots ((et:name et
:proto et
:aliases
) protoent et
:protoent
)
409 :for alias
:= (mem-aref et
:aliases
:string i
)
410 :while alias
:collect alias
)))
411 (make-protocol et
:name et
:proto alias-strings
))))
413 (defun get-protocol-by-number (protonum)
414 (make-protocol-from-protoent (et:getprotobynumber protonum
)))
416 (defun get-protocol-by-name (protoname)
417 (make-protocol-from-protoent (et:getprotobyname protoname
)))
419 (defun lookup-protocol (proto)
420 (let ((parsed-number (parse-number-or-nil proto
)))
423 (get-protocol-by-number parsed-number
)
424 (get-protocol-by-name proto
))
426 (error 'unknown-protocol
:name proto
)))))