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 :before
(host &key
(ipv6 *ipv6
*))
241 (declare (ignore host
))
242 (check-type ipv6
(member nil
:ipv6 t
) "valid IPv6 configuration"))
244 (defmethod lookup-host ((host string
) &key
(ipv6 *ipv6
*))
245 (flet ((decide-family-and-flags ()
247 ((nil) (values et
:af-inet
0))
248 ;; the freebsd I use rejects AI_V4MAPPED and AI_ALL(weird thing)
249 ;; therefore I'll use AF_UNSPEC and do the mappings myself
251 #-freebsd et
:af-inet6
252 #+freebsd et
:af-unspec
255 (logior et
:ai-v4mapped
256 #+freebsd et
:ai-v4mapped-cfg
258 (:ipv6
(values et
:af-inet6
0)))))
259 (multiple-value-bind (vector type
) (address-to-vector host
)
261 (:ipv4
(return-from lookup-host
262 (lookup-host-u8-vector-4 vector ipv6
)))
263 (:ipv6
(return-from lookup-host
264 (lookup-host-u16-vector-8 vector ipv6
)))
265 (t (multiple-value-bind (family flags
)
266 (decide-family-and-flags)
267 (setf flags
(logior flags et
:ai-canonname et
:ai-addrconfig
))
270 (get-address-info :node host
273 :hint-type et
:sock-stream
274 :hint-protocol et
:ipproto-ip
))
275 (hostobj (make-host-from-addrinfo addrinfo
)))
276 (when (string-not-equal (host-truename hostobj
)
278 (setf (slot-value hostobj
'aliases
) (list host
)))
279 (et:freeaddrinfo addrinfo
)
280 ;; mapping IPv4 addresses onto IPv6
283 (map-host-ipv4-addresses-to-ipv6 hostobj
))
284 (return-from lookup-host hostobj
))
285 (et:resolv-error
(err)
286 (resolver-error (et:system-error-identifier err
) :data host
)))))))))
288 (defmethod lookup-host (host &key
(ipv6 *ipv6
*))
289 (multiple-value-bind (vector type
) (address-to-vector host
)
291 (:ipv4
(lookup-host-u8-vector-4 vector ipv6
))
292 (:ipv6
(lookup-host-u16-vector-8 vector ipv6
)))))
294 (defun convert-or-lookup-inet-address (address &optional
(ipv6 *ipv6
*))
295 (or (ignore-errors (ensure-address address
:internet
))
296 (let ((addresses (host-addresses (lookup-host address
:ipv6 ipv6
))))
297 (values (car addresses
)
300 ;;;;;;;;;;;;;;;;;;;;;;;
301 ;;;;;;;;;;;;;;;;;;;;;;;
303 ;;; SERVICE LOOKUP ;;;
305 ;;;;;;;;;;;;;;;;;;;;;;;
306 ;;;;;;;;;;;;;;;;;;;;;;;
309 ((name :initarg
:name
:reader service-name
)
310 (port :initarg
:port
:reader service-port
)
311 (protocol :initarg
:protocol
:reader service-protocol
)))
313 (defun make-service (name port protocol
)
314 (make-instance 'service
319 (defmethod print-object ((service service
) stream
)
320 (print-unreadable-object (service stream
:type t
:identity nil
)
321 (with-slots (name port protocol
) service
322 (format stream
"Name: ~A. Port: ~A. Protocol: ~A" name port protocol
))))
324 (defun lookup-service-number (port-number protocol
&key name-required
)
325 (declare (type ub32 port-number
))
326 (with-foreign-object (sin 'et
:sockaddr-in
)
330 (et:bzero sin et
:size-of-sockaddr-in
)
331 (with-foreign-slots ((et:family et
:port
) sin et
:sockaddr-in
)
332 (setf et
:family et
:af-inet
333 et
:port
(htons port-number
)))
341 :want-host nil
:want-service t
)))))
342 (make-service service port-number protocol
))))
344 (defun lookup-service-name (port protocol
)
345 (flet ((protocol-type-to-int (protocol)
347 (:tcp et
:sock-stream
)
350 (socket-type-from-int (alien-val)
352 (#.et
:sock-stream
:tcp
)
353 (#.et
:sock-dgram
:udp
)
356 (get-address-info :service port
357 :hint-type
(protocol-type-to-int protocol
)))
359 (ntohs (foreign-slot-value (foreign-slot-value addrinfo
'et
:addrinfo
'et
:addr
)
360 'et
:sockaddr-in
'et
:port
)))
362 (socket-type-from-int (foreign-slot-value addrinfo
'et
:addrinfo
'et
:socktype
))))
363 (et:freeaddrinfo addrinfo
)
364 (return-from lookup-service-name
365 (make-service port port-number true-protocol
)))))
367 (defun lookup-service (port &key
(protocol :tcp
) (name-required nil
))
368 (check-type protocol
(member :tcp
:udp
:any
))
369 (let ((parsed-number (parse-number-or-nil port
:ub16
)))
372 (lookup-service-number parsed-number protocol
373 :name-required name-required
)
374 (lookup-service-name port protocol
))
375 (et:resolv-error
(err)
376 (resolver-error (et:system-error-identifier err
) :data port
)))))
380 ;;;;;;;;;;;;;;;;;;;;;;;;
381 ;;;;;;;;;;;;;;;;;;;;;;;;
383 ;;; PROTOCOL LOOKUP ;;;
385 ;;;;;;;;;;;;;;;;;;;;;;;;
386 ;;;;;;;;;;;;;;;;;;;;;;;;
388 (defclass protocol
()
389 ((name :initarg
:name
:reader protocol-name
)
390 (aliases :initarg
:aliases
:reader protocol-aliases
)
391 (protonum :initarg
:protonum
:reader protocol-number
)))
393 (defun make-protocol (name protonum
&optional aliases
)
394 (make-instance 'protocol
399 (defmethod print-object ((protocol protocol
) stream
)
400 (print-unreadable-object (protocol stream
:type t
:identity nil
)
401 (with-slots (name aliases protonum
) protocol
402 (format stream
"Name: ~S. Protocol number: ~A. Aliases: ~{~S~^, ~}"
403 name protonum aliases
))))
405 (define-condition unknown-protocol
(system-error)
406 ((name :initarg
:name
:initform nil
:reader protocol-name
))
407 (:report
(lambda (condition stream
)
408 (format stream
"Unknown protocol: ~S"
409 (protocol-name condition
))))
410 (:documentation
"Condition raised when a network protocol is not found."))
412 (defun make-protocol-from-protoent (protoent)
413 (with-foreign-slots ((et:name et
:proto et
:aliases
) protoent et
:protoent
)
417 :for alias
:= (mem-aref et
:aliases
:string i
)
418 :while alias
:collect alias
)))
419 (make-protocol et
:name et
:proto alias-strings
))))
421 (defun get-protocol-by-number (protonum)
422 (make-protocol-from-protoent (et:getprotobynumber protonum
)))
424 (defun get-protocol-by-name (protoname)
425 (make-protocol-from-protoent (et:getprotobyname protoname
)))
427 (defun lookup-protocol (proto)
428 (let ((parsed-number (parse-number-or-nil proto
)))
431 (get-protocol-by-number parsed-number
)
432 (get-protocol-by-name proto
))
434 (error 'unknown-protocol
:name proto
)))))