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
&key
27 fd input-buffer-size output-buffer-size
)
28 (make-instance (select-socket-class family type connect
:default
)
29 :family family
:file-descriptor fd
30 :external-format external-format
31 :input-buffer-size input-buffer-size
32 :output-buffer-size output-buffer-size
))
34 (define-compiler-macro create-socket
(&whole form family type connect external-format
35 &key fd input-buffer-size output-buffer-size
)
37 ((and (constantp family
) (constantp type
) (constantp connect
))
38 `(make-instance ',(select-socket-class family type connect
:default
)
39 :family
,family
:file-descriptor
,fd
40 :external-format
,external-format
41 :input-buffer-size
,input-buffer-size
42 :output-buffer-size
,output-buffer-size
))
45 (defmacro with-close-on-error
((var value
) &body body
)
46 "Bind `VAR' to `VALUE', execute `BODY' as implicit PROGN and return `VAR'.
47 If a non-local exit occurs during the execution of `BODY' call CLOSE with :ABORT T on `VAR'."
48 (with-gensyms (errorp)
49 `(let ((,var
,value
) (,errorp t
))
51 (multiple-value-prog1 (locally ,@body
,var
) (setf ,errorp nil
))
52 (when (and ,var
,errorp
) (close ,var
:abort t
))))))
54 (defmacro %create-internet-socket
(family &rest args
)
56 (:ipv4
(create-socket :ipv4
,@args
))
57 (:ipv6
(create-socket :ipv6
,@args
))))
59 (defmacro with-guard-again-non-list-args-and-destructuring-bind-errors
60 (form args
&body body
)
62 (handler-case (progn ,@body
)
63 (error (err) `(error ,err
)))
66 ;;; Internet Stream Active Socket creation
68 (defun %%init-internet-stream-active-socket
(socket keepalive nodelay reuse-address
69 local-host local-port remote-host remote-port
)
70 (let ((local-port (ensure-numerical-service local-port
))
71 (remote-port (ensure-numerical-service remote-port
)))
72 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
73 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
75 (bind-address socket
(ensure-hostname local-host
)
77 :reuse-address reuse-address
))
78 (when (plusp remote-port
)
79 (connect socket
(ensure-hostname remote-host
)
82 (declaim (inline %%make-internet-stream-active-socket
))
83 (defun %%make-internet-stream-active-socket
(family ef keepalive nodelay reuse-address
84 local-host local-port remote-host remote-port
85 input-buffer-size output-buffer-size
)
86 (with-close-on-error (socket (%create-internet-socket family
:stream
:active ef
87 :input-buffer-size input-buffer-size
88 :output-buffer-size output-buffer-size
))
89 (%%init-internet-stream-active-socket socket keepalive nodelay reuse-address
90 local-host local-port remote-host remote-port
)))
92 (defun %make-internet-stream-active-socket
(args family ef
)
93 (destructuring-bind (&key keepalive nodelay
(reuse-address t
)
94 local-host
(local-port 0)
95 (remote-host +any-host
+) (remote-port 0)
96 input-buffer-size output-buffer-size
)
98 (%%make-internet-stream-active-socket family ef keepalive nodelay reuse-address
99 local-host local-port remote-host remote-port
100 input-buffer-size output-buffer-size
)))
102 (define-compiler-macro %make-internet-stream-active-socket
(&whole form args family ef
)
103 (with-guard-again-non-list-args-and-destructuring-bind-errors
105 (destructuring-bind (&key keepalive nodelay
(reuse-address t
)
106 local-host
(local-port 0)
107 (remote-host +any-host
+) (remote-port 0)
108 input-buffer-size output-buffer-size
)
110 `(%%make-internet-stream-active-socket
,family
,ef
,keepalive
,nodelay
,reuse-address
111 ,local-host
,local-port
,remote-host
,remote-port
112 ,input-buffer-size
,output-buffer-size
))))
114 ;;; Internet Stream Passive Socket creation
116 (defun %%init-internet-stream-passive-socket
(socket interface reuse-address
117 local-host local-port backlog
)
118 (let ((local-port (ensure-numerical-service local-port
)))
121 (setf (socket-option socket
:bind-to-device
) interface
))
122 (bind-address socket
(ensure-hostname local-host
)
124 :reuse-address reuse-address
)
125 (listen-on socket
:backlog backlog
))))
127 (declaim (inline %%make-internet-stream-passive-socket
))
128 (defun %%make-internet-stream-passive-socket
(family ef interface reuse-address
129 local-host local-port backlog
)
130 (with-close-on-error (socket (%create-internet-socket family
:stream
:passive ef
))
131 (%%init-internet-stream-passive-socket socket interface reuse-address
132 local-host local-port backlog
)))
134 (defun %make-internet-stream-passive-socket
(args family ef
)
135 (destructuring-bind (&key interface
(reuse-address t
)
136 (local-host +any-host
+) (local-port 0)
137 (backlog *default-backlog-size
*))
139 (%%make-internet-stream-passive-socket family ef interface reuse-address
140 local-host local-port backlog
)))
142 (define-compiler-macro %make-internet-stream-passive-socket
(&whole form args family ef
)
143 (with-guard-again-non-list-args-and-destructuring-bind-errors
145 (destructuring-bind (&key interface
(reuse-address t
)
146 (local-host +any-host
+) (local-port 0)
147 (backlog *default-backlog-size
*))
149 `(%%make-internet-stream-passive-socket
,family
,ef
,interface
,reuse-address
150 ,local-host
,local-port
,backlog
))))
152 ;;; Local Stream Active Socket creation
154 (defun %%init-local-stream-active-socket
(socket local-filename remote-filename
)
156 (bind-address socket
(ensure-address local-filename
:family
:local
)))
157 (when remote-filename
158 (connect socket
(ensure-address remote-filename
:family
:local
))))
160 (declaim (inline %%make-local-stream-active-socket
))
161 (defun %%make-local-stream-active-socket
(family ef local-filename remote-filename
162 input-buffer-size output-buffer-size
)
163 (declare (ignore family
))
164 (with-close-on-error (socket (create-socket :local
:stream
:active ef
165 :input-buffer-size input-buffer-size
166 :output-buffer-size output-buffer-size
))
167 (%%init-local-stream-active-socket socket local-filename remote-filename
)))
169 (defun %make-local-stream-active-socket
(args family ef
)
170 (destructuring-bind (&key local-filename remote-filename
171 input-buffer-size output-buffer-size
)
173 (%%make-local-stream-active-socket family ef local-filename remote-filename
174 input-buffer-size output-buffer-size
)))
176 (define-compiler-macro %make-local-stream-active-socket
(&whole form args family ef
)
177 (with-guard-again-non-list-args-and-destructuring-bind-errors
179 (destructuring-bind (&key local-filename remote-filename
180 input-buffer-size output-buffer-size
)
182 `(%%make-local-stream-active-socket
,family
,ef
,local-filename
,remote-filename
183 ,input-buffer-size
,output-buffer-size
))))
185 ;;; Local Stream Passive Socket creation
187 (defun %%init-local-stream-passive-socket
(socket local-filename reuse-address backlog
)
189 (bind-address socket
(ensure-address local-filename
:family
:local
)
190 :reuse-address reuse-address
)
191 (listen-on socket
:backlog backlog
)))
193 (declaim (inline %%make-local-stream-passive-socket
))
194 (defun %%make-local-stream-passive-socket
(family ef local-filename reuse-address backlog
)
195 (declare (ignore family
))
196 (with-close-on-error (socket (create-socket :local
:stream
:passive ef
))
197 (%%init-local-stream-passive-socket socket local-filename reuse-address backlog
)))
199 (defun %make-local-stream-passive-socket
(args family ef
)
200 (destructuring-bind (&key local-filename
(reuse-address t
)
201 (backlog *default-backlog-size
*))
203 (%%make-local-stream-passive-socket family ef local-filename reuse-address backlog
)))
205 (define-compiler-macro %make-local-stream-passive-socket
(&whole form args family ef
)
206 (with-guard-again-non-list-args-and-destructuring-bind-errors
208 (destructuring-bind (&key local-filename
(reuse-address t
)
209 (backlog *default-backlog-size
*))
211 `(%%make-local-stream-passive-socket
,family
,ef
,local-filename
,reuse-address
,backlog
))))
213 ;;; Internet Datagram Socket creation
215 (defun %%init-internet-datagram-socket
(socket broadcast interface reuse-address
216 local-host local-port remote-host remote-port
)
217 (let ((local-port (ensure-numerical-service local-port
))
218 (remote-port (ensure-numerical-service remote-port
)))
219 (when broadcast
(setf (socket-option socket
:broadcast
) t
))
221 (bind-address socket
(ensure-hostname local-host
)
223 :reuse-address reuse-address
)
225 (setf (socket-option socket
:bind-to-device
) interface
)))
226 (when (plusp remote-port
)
227 (connect socket
(ensure-hostname remote-host
)
228 :port remote-port
))))
230 (declaim (inline %%make-internet-datagram-socket
))
231 (defun %%make-internet-datagram-socket
(family ef broadcast interface reuse-address
232 local-host local-port remote-host remote-port
)
233 (with-close-on-error (socket (%create-internet-socket family
:datagram
:active ef
))
234 (%%init-internet-datagram-socket socket broadcast interface reuse-address
235 local-host local-port remote-host remote-port
)))
237 (defun %make-internet-datagram-socket
(args family ef
)
238 (destructuring-bind (&key broadcast interface
(reuse-address t
)
239 local-host
(local-port 0)
240 (remote-host +any-host
+) (remote-port 0))
242 (%%make-internet-datagram-socket family ef broadcast interface reuse-address
243 local-host local-port remote-host remote-port
)))
245 (define-compiler-macro %make-internet-datagram-socket
(&whole form args family ef
)
246 (with-guard-again-non-list-args-and-destructuring-bind-errors
248 (destructuring-bind (&key broadcast interface
(reuse-address t
)
249 local-host
(local-port 0)
250 (remote-host +any-host
+) (remote-port 0))
252 `(%%make-internet-datagram-socket
,family
,ef
,broadcast
,interface
,reuse-address
253 ,local-host
,local-port
,remote-host
,remote-port
))))
255 ;;; Local Datagram Socket creation
257 (defun %%init-local-datagram-socket
(socket local-filename remote-filename
)
259 (bind-address socket
(ensure-address local-filename
:family
:local
)))
260 (when remote-filename
261 (connect socket
(ensure-address remote-filename
:family
:local
))))
263 (declaim (inline %%make-local-datagram-socket
))
264 (defun %%make-local-datagram-socket
(family ef local-filename remote-filename
)
265 (declare (ignore family
))
266 (with-close-on-error (socket (create-socket :local
:datagram
:active ef
))
267 (%%init-local-datagram-socket socket local-filename remote-filename
)))
269 (defun %make-local-datagram-socket
(args family ef
)
270 (destructuring-bind (&key local-filename remote-filename
)
272 (%%make-local-datagram-socket family ef local-filename remote-filename
)))
274 (define-compiler-macro %make-local-datagram-socket
(&whole form args family ef
)
275 (with-guard-again-non-list-args-and-destructuring-bind-errors
277 (destructuring-bind (&key local-filename remote-filename
)
279 `(%%make-local-datagram-socket
,family
,ef
,local-filename
,remote-filename
))))
283 (defun make-socket (&rest args
&key
(family :internet
) (type :stream
)
284 (connect :active
) (ipv6 *ipv6
*)
285 (external-format :default
) &allow-other-keys
)
286 "Creates a socket instance of the appropriate subclass of SOCKET."
287 (check-type family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
288 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
289 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
290 (let ((args (remove-from-plist args
:family
:type
:connect
:external-format
:ipv6
)))
291 (when (eq :ipv4 family
) (setf ipv6 nil
))
293 (when (eq :internet family
) (setf family
+default-inet-family
+))
294 (multiple-value-case ((family type connect
) :test
#'eq
)
295 (((:ipv4
:ipv6
) :stream
:active
)
296 (%make-internet-stream-active-socket args family external-format
))
297 (((:ipv4
:ipv6
) :stream
:passive
)
298 (%make-internet-stream-passive-socket args family external-format
))
299 ((:local
:stream
:active
)
300 (%make-local-stream-active-socket args
:local external-format
))
301 ((:local
:stream
:passive
)
302 (%make-local-stream-passive-socket args
:local external-format
))
303 (((:ipv4
:ipv6
) :datagram
)
304 (%make-internet-datagram-socket args family external-format
))
306 (%make-local-datagram-socket args
:local external-format
))))))
308 (define-compiler-macro make-socket
(&whole form
&rest args
&key
(family :internet
) (type :stream
)
309 (connect :active
) (ipv6 '*ipv6
* ipv6p
)
310 (external-format :default
) &allow-other-keys
)
312 ((and (constantp family
) (constantp type
) (constantp connect
))
313 (check-type family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
314 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
315 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
316 (let ((lower-function
317 (multiple-value-case ((family type connect
) :test
#'eq
)
318 (((:ipv4
:ipv6
:internet
) :stream
:active
) '%make-internet-stream-active-socket
)
319 (((:ipv4
:ipv6
:internet
) :stream
:passive
) '%make-internet-stream-passive-socket
)
320 ((:local
:stream
:active
) '%make-local-stream-active-socket
)
321 ((:local
:stream
:passive
) '%make-local-stream-passive-socket
)
322 (((:ipv4
:ipv6
:internet
) :datagram
) '%make-internet-datagram-socket
)
323 ((:local
:datagram
) '%make-local-datagram-socket
)))
324 (newargs (remove-from-plist args
:family
:type
:connect
:external-format
:ipv6
)))
325 (multiple-value-case (family)
326 (:internet
(setf family
'+default-inet-family
+))
327 (:ipv4
(setf ipv6 nil
)))
328 (let ((expansion `(,lower-function
(list ,@newargs
) ,family
,external-format
)))
329 (if (or ipv6p
(eq :ipv4 family
))
330 `(let ((*ipv6
* ,ipv6
)) ,expansion
)
334 (defmacro with-open-socket
((var &rest args
) &body body
)
335 "VAR is bound to a socket created by passing ARGS to
336 MAKE-SOCKET and BODY is executed as implicit PROGN. The socket
337 is automatically closed upon exit."
338 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
340 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
341 "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
342 ACCEPT-CONNECTION and BODY is executed as implicit PROGN. The socket
343 is automatically closed upon exit."
344 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
346 ;;; MAKE-SOCKET-FROM-FD
348 ;;; FIXME: must come up with a way to find out
349 ;;; whether a socket is active or passive
350 (defun make-socket-from-fd (fd &key
(connect :active
) (external-format :default
) (errorp t
)
351 input-buffer-size output-buffer-size
)
352 "Creates an socket instance of the appropriate subclass of SOCKET using `FD'.
353 The connection type of the socket must be specified(:ACTIVE or :PASSIVE).
354 The address family and type of the socket is automatically discovered using OS functions. Buffer sizes
355 for the new socket can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'.
356 If `FD' is an invalid socket descriptor and `ERRORP' is not NIL a condition subtype of POSIX-ERROR
357 is signaled, otherwise two values are returned: NIL and the specific condition object."
358 (labels ((%get-address-family
(fd)
359 (with-sockaddr-storage-and-socklen (ss size
)
360 (%getsockname fd ss size
)
361 (foreign-slot-value ss
'sockaddr-storage
'family
)
362 (eswitch ((foreign-slot-value ss
'sockaddr-storage
'family
) :test
#'=)
367 (eswitch ((get-socket-option-int fd sol-socket so-type
) :test
#'=)
368 (sock-stream :stream
)
369 (sock-dgram :datagram
)))
370 (%make-socket-from-fd
()
371 (create-socket (%get-address-family fd
)
373 connect external-format
:fd fd
374 :input-buffer-size input-buffer-size
375 :output-buffer-size output-buffer-size
)))
377 (%make-socket-from-fd
)
378 (ignore-some-conditions (posix-error)
379 (%make-socket-from-fd
)))))
383 (defun make-socket-pair (&key
(type :stream
) (protocol :default
) (external-format :default
)
384 input-buffer-size output-buffer-size
)
385 "Creates an pair of sockets connected to each other.
386 The socket type can be either :STREAM or DATAGRAM. Currently OSes can only create :LOCAL sockets this way.
387 Buffer sizes for the new sockets can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
388 (flet ((%make-socket-pair
(fd)
389 (make-socket-from-fd fd
:external-format external-format
390 :input-buffer-size input-buffer-size
391 :output-buffer-size output-buffer-size
)))
392 (multiple-value-bind (fd1 fd2
)
393 (multiple-value-call #'%socketpair
394 (translate-make-socket-keywords-to-constants :local type protocol
))
395 (values (%make-socket-pair fd1
)
396 (%make-socket-pair fd2
)))))