1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; make-socket.lisp --- Socket creation.
5 ;;; Copyright (C) 2006-2008, 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 (defun create-socket (family type connect external-format
&optional fd
)
27 (make-instance (select-socket-class family type connect
:default
)
28 :family family
:file-descriptor fd
29 :external-format external-format
))
31 (defmacro with-close-on-error
((var value
) &body body
)
32 "Bind VAR to VALUE, execute BODY as implicit PROGN and return VAR.
33 On error call CLOSE with :ABORT T on VAR."
34 (with-gensyms (errorp)
35 `(let ((,var
,value
) (,errorp t
))
37 (multiple-value-prog1 (locally ,@body
,var
) (setf ,errorp nil
))
38 (when (and ,var
,errorp
) (close ,var
:abort t
))))))
40 (defmacro with-guard-again-non-list-args-and-destructuring-bind-errors
41 (form args
&body body
)
43 (handler-case (progn ,@body
)
44 (error (err) `(error ,err
)))
47 (defun convert-or-lookup-inet-address (address &optional
(ipv6 *ipv6
*))
48 "If ADDRESS is an inet-address designator, it is converted, if
49 necessary, to an INET-ADDRESS object and returned. Otherwise it
50 is assumed to be a host name which is then looked up in order to
51 return its primary address as the first return value and the
52 remaining address list as the second return value."
53 (or (ignore-parse-errors (ensure-address address
:internet
))
54 (let ((addresses (lookup-host address
:ipv6 ipv6
)))
55 (values (car addresses
) (cdr addresses
)))))
57 (define-symbol-macro +default-host
+
58 (if *ipv6
* +ipv6-unspecified
+ +ipv4-unspecified
+))
60 ;;; Internet Stream Active Socket creation
62 (defun %%make-internet-stream-active-socket
(family ef keepalive nodelay reuse-address
63 local-host local-port remote-host remote-port
)
64 (let ((local-port (ensure-numerical-service local-port
))
65 (remote-port (ensure-numerical-service remote-port
)))
66 (with-close-on-error (socket (create-socket family
:stream
:active ef
))
67 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
68 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
70 (bind-address socket
(convert-or-lookup-inet-address local-host
)
72 :reuse-address reuse-address
))
73 (when (plusp remote-port
)
74 (connect socket
(convert-or-lookup-inet-address remote-host
)
75 :port remote-port
)))))
77 (defun %make-internet-stream-active-socket
(args family ef
)
78 (destructuring-bind (&key keepalive nodelay
(reuse-address t
)
79 local-host
(local-port 0)
80 (remote-host +default-host
+) (remote-port 0))
82 (%%make-internet-stream-active-socket family ef keepalive nodelay reuse-address
83 local-host local-port remote-host remote-port
)))
85 (define-compiler-macro %make-internet-stream-active-socket
(&whole form args family ef
)
86 (with-guard-again-non-list-args-and-destructuring-bind-errors
88 (destructuring-bind (&key keepalive nodelay
(reuse-address t
)
89 local-host
(local-port 0)
90 (remote-host +default-host
+) (remote-port 0))
92 `(%%make-internet-stream-active-socket
,family
,ef
,keepalive
,nodelay
,reuse-address
93 ,local-host
,local-port
,remote-host
,remote-port
))))
95 ;;; Internet Stream Passive Socket creation
97 (defun %%make-internet-stream-passive-socket
(family ef interface reuse-address
98 local-host local-port backlog
)
99 (let ((local-port (ensure-numerical-service local-port
)))
100 (with-close-on-error (socket (create-socket family
:stream
:passive ef
))
103 (setf (socket-option socket
:bind-to-device
) interface
))
104 (bind-address socket
(convert-or-lookup-inet-address local-host
)
106 :reuse-address reuse-address
)
107 (socket-listen socket
:backlog backlog
)))))
109 (defun %make-internet-stream-passive-socket
(args family ef
)
110 (destructuring-bind (&key interface
(reuse-address t
)
111 (local-host +default-host
+) (local-port 0)
112 (backlog *default-backlog-size
*))
114 (%%make-internet-stream-passive-socket family ef interface reuse-address
115 local-host local-port backlog
)))
117 (define-compiler-macro %make-internet-stream-passive-socket
(&whole form args family ef
)
118 (with-guard-again-non-list-args-and-destructuring-bind-errors
120 (destructuring-bind (&key interface
(reuse-address t
)
121 (local-host +default-host
+) (local-port 0)
122 (backlog *default-backlog-size
*))
124 `(%%make-internet-stream-passive-socket
,family
,ef
,interface
,reuse-address
125 ,local-host
,local-port
,backlog
))))
127 ;;; Local Stream Active Socket creation
129 (defun %%make-local-stream-active-socket
(family ef local-filename remote-filename
)
130 (with-close-on-error (socket (create-socket family
:stream
:active ef
))
132 (bind-address socket
(ensure-address local-filename
:local
)))
133 (when remote-filename
134 (connect socket
(ensure-address remote-filename
:local
)))))
136 (defun %make-local-stream-active-socket
(args family ef
)
137 (destructuring-bind (&key local-filename remote-filename
)
139 (%%make-local-stream-active-socket family ef local-filename remote-filename
)))
141 (define-compiler-macro %make-local-stream-active-socket
(&whole form args family ef
)
142 (with-guard-again-non-list-args-and-destructuring-bind-errors
144 (destructuring-bind (&key local-filename remote-filename
)
146 `(%%make-local-stream-active-socket
,family
,ef
,local-filename
,remote-filename
))))
148 ;;; Local Stream Passive Socket creation
150 (defun %%make-local-stream-passive-socket
(family ef local-filename reuse-address backlog
)
151 (with-close-on-error (socket (create-socket family
:stream
:passive ef
))
153 (bind-address socket
(ensure-address local-filename
:local
)
154 :reuse-address reuse-address
)
155 (socket-listen socket
:backlog backlog
))))
157 (defun %make-local-stream-passive-socket
(args family ef
)
158 (destructuring-bind (&key local-filename
(reuse-address t
)
159 (backlog *default-backlog-size
*))
161 (%%make-local-stream-passive-socket family ef local-filename reuse-address backlog
)))
163 (define-compiler-macro %make-local-stream-passive-socket
(&whole form args family ef
)
164 (with-guard-again-non-list-args-and-destructuring-bind-errors
166 (destructuring-bind (&key local-filename
(reuse-address t
)
167 (backlog *default-backlog-size
*))
169 `(%%make-local-stream-passive-socket
,family
,ef
,local-filename
,reuse-address
,backlog
))))
171 ;;; Internet Datagram Socket creation
173 (defun %%make-internet-datagram-socket
(family ef broadcast interface reuse-address
174 local-host local-port remote-host remote-port
)
175 (let ((local-port (ensure-numerical-service local-port
))
176 (remote-port (ensure-numerical-service remote-port
)))
177 (with-close-on-error (socket (create-socket family
:datagram
:active ef
))
178 (when broadcast
(setf (socket-option socket
:broadcast
) t
))
180 (bind-address socket
(convert-or-lookup-inet-address local-host
)
182 :reuse-address reuse-address
)
184 (setf (socket-option socket
:bind-to-device
) interface
)))
185 (when (plusp remote-port
)
186 (connect socket
(convert-or-lookup-inet-address remote-host
)
187 :port remote-port
)))))
189 (defun %make-internet-datagram-socket
(args family ef
)
190 (destructuring-bind (&key broadcast interface
(reuse-address t
)
191 local-host
(local-port 0)
192 (remote-host +default-host
+) (remote-port 0))
194 (%%make-internet-datagram-socket family ef broadcast interface reuse-address
195 local-host local-port remote-host remote-port
)))
197 (define-compiler-macro %make-internet-datagram-socket
(&whole form args family ef
)
198 (with-guard-again-non-list-args-and-destructuring-bind-errors
200 (destructuring-bind (&key broadcast interface
(reuse-address t
)
201 local-host
(local-port 0)
202 (remote-host +default-host
+) (remote-port 0))
204 `(%%make-internet-datagram-socket
,family
,ef
,broadcast
,interface
,reuse-address
205 ,local-host
,local-port
,remote-host
,remote-port
))))
207 ;;; Local Datagram Socket creation
209 (defun %%make-local-datagram-socket
(family ef local-filename remote-filename
)
210 (with-close-on-error (socket (create-socket family
:datagram
:active ef
))
212 (bind-address socket
(ensure-address local-filename
:local
)))
213 (when remote-filename
214 (connect socket
(ensure-address remote-filename
:local
)))))
216 (defun %make-local-datagram-socket
(args family ef
)
217 (destructuring-bind (&key local-filename remote-filename
)
219 (%%make-local-datagram-socket family ef local-filename remote-filename
)))
221 (define-compiler-macro %make-local-datagram-socket
(&whole form args family ef
)
222 (with-guard-again-non-list-args-and-destructuring-bind-errors
224 (destructuring-bind (&key local-filename remote-filename
)
226 `(%%make-local-datagram-socket
,family
,ef
,local-filename
,remote-filename
))))
230 (defun make-socket (&rest args
&key
(family :internet
) (type :stream
)
231 (connect :active
) (ipv6 *ipv6
*)
232 (external-format :default
) &allow-other-keys
)
233 "Creates a socket instance of the appropriate subclass of SOCKET."
234 (check-type family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
235 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
236 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
237 (let ((args (remove-from-plist args
:family
:type
:connect
:external-format
:ipv6
)))
239 (:internet
(setf family
+default-inet-family
+))
240 (:ipv4
(setf ipv6 nil
)))
242 (multiple-value-case (family type connect
)
243 (((:ipv4
:ipv6
) :stream
:active
)
244 (%make-internet-stream-active-socket args family external-format
))
245 (((:ipv4
:ipv6
) :stream
:passive
)
246 (%make-internet-stream-passive-socket args family external-format
))
247 ((:local
:stream
:active
)
248 (%make-local-stream-active-socket args
:local external-format
))
249 ((:local
:stream
:passive
)
250 (%make-local-stream-passive-socket args
:local external-format
))
251 (((:ipv4
:ipv6
) :datagram
)
252 (%make-internet-datagram-socket args family external-format
))
254 (%make-local-datagram-socket args
:local external-format
))))))
256 (define-compiler-macro make-socket
(&whole form
&rest args
&key
(family :internet
) (type :stream
)
257 (connect :active
) (ipv6 '*ipv6
*)
258 (external-format :default
) &allow-other-keys
)
260 ((and (constantp family
) (constantp type
) (constantp connect
))
261 (check-type family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
262 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
263 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
264 (let ((lower-function
265 (multiple-value-case (family type connect
)
266 (((:ipv4
:ipv6
:internet
) :stream
:active
) '%make-internet-stream-active-socket
)
267 (((:ipv4
:ipv6
:internet
) :stream
:passive
) '%make-internet-stream-passive-socket
)
268 ((:local
:stream
:active
) '%make-local-stream-active-socket
)
269 ((:local
:stream
:passive
) '%make-local-stream-passive-socket
)
270 (((:ipv4
:ipv6
:internet
) :datagram
) '%make-internet-datagram-socket
)
271 ((:local
:datagram
) '%make-local-datagram-socket
)))
272 (newargs (remove-from-plist args
'(:family
:type
:connect
:external-format
:ipv6
))))
274 (:internet
(setf family
'+default-inet-family
+))
275 (:ipv4
(setf ipv6 nil
)))
276 `(let ((*ipv6
* ,ipv6
))
277 (,lower-function
(list ,@newargs
) ,family
,external-format
))))
280 (defmacro with-open-socket
((var &rest args
) &body body
)
281 "VAR is bound to a socket created by passing ARGS to
282 MAKE-SOCKET and BODY is executed as implicit PROGN. The socket
283 is automatically closed upon exit."
284 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
286 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
287 "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
288 ACCEPT-CONNECTION and BODY is executed as implicit PROGN. The socket
289 is automatically closed upon exit."
290 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
292 ;;; MAKE-SOCKET-STREAM
294 (defun get-address-family (fd)
295 (with-sockaddr-storage (ss)
296 (with-socklen (size size-of-sockaddr-storage
)
297 (%getsockname fd ss size
)
298 (foreign-slot-value ss
'sockaddr-storage
'family
))))
300 (defun make-socket-stream (fd &key
(external-format :default
) (errorp t
))
301 "Creates an active stream socket instance of the appropriate subclass of SOCKET using `FD'.
302 The address family of the sockets is automatically discovered using OS functions. If `FD' is
303 an invalid socket descriptor and `ERRORP' is not NIL a condition subtype of POSIX-ERROR
304 is signaled, otherwise two values are returned: NIL and the specific condition object."
305 (flet ((%make-socket-stream
()
306 (let ((family (switch ((get-address-family fd
) :test
#'=)
310 (create-socket family
:stream
:active external-format fd
))))
312 (%make-socket-stream
)
313 (ignore-some-conditions (posix-error)
314 (%make-socket-stream
)))))