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 fd input-buffer-size output-buffer-size
)
28 ;; this is necessary because passive sockets don't inherit from
29 ;; stream classes, therefore keyword args :INPUT-BUFFER-SIZE and
30 ;; :OUTPUT-BUFFER-SIZE are invalid for them
31 ((or input-buffer-size output-buffer-size
)
32 (assert (eq connect
:active
))
33 (make-instance (select-socket-class family type connect
:default
)
34 :family family
:file-descriptor fd
35 :external-format external-format
36 :input-buffer-size input-buffer-size
37 :output-buffer-size output-buffer-size
))
38 (t (make-instance (select-socket-class family type connect
:default
)
39 :family family
:file-descriptor fd
40 :external-format external-format
))))
42 (defmacro with-close-on-error
((var value
) &body body
)
43 "Bind `VAR' to `VALUE', execute `BODY' as implicit PROGN and return `VAR'.
44 If a non-local exit occurs during the execution of `BODY' call CLOSE with :ABORT T on `VAR'."
45 (with-gensyms (errorp)
46 `(let ((,var
,value
) (,errorp t
))
48 (multiple-value-prog1 (locally ,@body
,var
) (setf ,errorp nil
))
49 (when (and ,var
,errorp
) (close ,var
:abort t
))))))
51 (defmacro with-guard-again-non-list-args-and-destructuring-bind-errors
52 (form args
&body body
)
54 (handler-case (progn ,@body
)
55 (error (err) `(error ,err
)))
58 ;;; Internet Stream Active Socket creation
60 (defun %%make-internet-stream-active-socket
(family ef keepalive nodelay reuse-address
61 local-host local-port remote-host remote-port
62 input-buffer-size output-buffer-size
)
63 (let ((local-port (ensure-numerical-service local-port
))
64 (remote-port (ensure-numerical-service remote-port
)))
65 (with-close-on-error (socket (create-socket family
:stream
:active ef
66 :input-buffer-size input-buffer-size
67 :output-buffer-size output-buffer-size
))
68 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
69 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
71 (bind-address socket
(ensure-hostname local-host
)
73 :reuse-address reuse-address
))
74 (when (plusp remote-port
)
75 (connect socket
(ensure-hostname remote-host
)
76 :port remote-port
)))))
78 (defun %make-internet-stream-active-socket
(args family ef
)
79 (destructuring-bind (&key keepalive nodelay
(reuse-address t
)
80 local-host
(local-port 0)
81 (remote-host +any-host
+) (remote-port 0)
82 input-buffer-size output-buffer-size
)
84 (%%make-internet-stream-active-socket family ef keepalive nodelay reuse-address
85 local-host local-port remote-host remote-port
86 input-buffer-size output-buffer-size
)))
88 (define-compiler-macro %make-internet-stream-active-socket
(&whole form args family ef
)
89 (with-guard-again-non-list-args-and-destructuring-bind-errors
91 (destructuring-bind (&key keepalive nodelay
(reuse-address t
)
92 local-host
(local-port 0)
93 (remote-host +any-host
+) (remote-port 0)
94 input-buffer-size output-buffer-size
)
96 `(%%make-internet-stream-active-socket
,family
,ef
,keepalive
,nodelay
,reuse-address
97 ,local-host
,local-port
,remote-host
,remote-port
98 ,input-buffer-size
,output-buffer-size
))))
100 ;;; Internet Stream Passive Socket creation
102 (defun %%make-internet-stream-passive-socket
(family ef interface reuse-address
103 local-host local-port backlog
)
104 (let ((local-port (ensure-numerical-service local-port
)))
105 (with-close-on-error (socket (create-socket family
:stream
:passive ef
))
108 (setf (socket-option socket
:bind-to-device
) interface
))
109 (bind-address socket
(ensure-hostname local-host
)
111 :reuse-address reuse-address
)
112 (listen-on socket
:backlog backlog
)))))
114 (defun %make-internet-stream-passive-socket
(args family ef
)
115 (destructuring-bind (&key interface
(reuse-address t
)
116 (local-host +any-host
+) (local-port 0)
117 (backlog *default-backlog-size
*))
119 (%%make-internet-stream-passive-socket family ef interface reuse-address
120 local-host local-port backlog
)))
122 (define-compiler-macro %make-internet-stream-passive-socket
(&whole form args family ef
)
123 (with-guard-again-non-list-args-and-destructuring-bind-errors
125 (destructuring-bind (&key interface
(reuse-address t
)
126 (local-host +any-host
+) (local-port 0)
127 (backlog *default-backlog-size
*))
129 `(%%make-internet-stream-passive-socket
,family
,ef
,interface
,reuse-address
130 ,local-host
,local-port
,backlog
))))
132 ;;; Local Stream Active Socket creation
134 (defun %%make-local-stream-active-socket
(family ef local-filename remote-filename
135 input-buffer-size output-buffer-size
)
136 (with-close-on-error (socket (create-socket family
:stream
:active ef
137 :input-buffer-size input-buffer-size
138 :output-buffer-size output-buffer-size
))
140 (bind-address socket
(ensure-address local-filename
:family
:local
)))
141 (when remote-filename
142 (connect socket
(ensure-address remote-filename
:family
:local
)))))
144 (defun %make-local-stream-active-socket
(args family ef
)
145 (destructuring-bind (&key local-filename remote-filename
146 input-buffer-size output-buffer-size
)
148 (%%make-local-stream-active-socket family ef local-filename remote-filename
149 input-buffer-size output-buffer-size
)))
151 (define-compiler-macro %make-local-stream-active-socket
(&whole form args family ef
)
152 (with-guard-again-non-list-args-and-destructuring-bind-errors
154 (destructuring-bind (&key local-filename remote-filename
155 input-buffer-size output-buffer-size
)
157 `(%%make-local-stream-active-socket
,family
,ef
,local-filename
,remote-filename
158 ,input-buffer-size
,output-buffer-size
))))
160 ;;; Local Stream Passive Socket creation
162 (defun %%make-local-stream-passive-socket
(family ef local-filename reuse-address backlog
)
163 (with-close-on-error (socket (create-socket family
:stream
:passive ef
))
165 (bind-address socket
(ensure-address local-filename
:family
:local
)
166 :reuse-address reuse-address
)
167 (listen-on socket
:backlog backlog
))))
169 (defun %make-local-stream-passive-socket
(args family ef
)
170 (destructuring-bind (&key local-filename
(reuse-address t
)
171 (backlog *default-backlog-size
*))
173 (%%make-local-stream-passive-socket family ef local-filename reuse-address backlog
)))
175 (define-compiler-macro %make-local-stream-passive-socket
(&whole form args family ef
)
176 (with-guard-again-non-list-args-and-destructuring-bind-errors
178 (destructuring-bind (&key local-filename
(reuse-address t
)
179 (backlog *default-backlog-size
*))
181 `(%%make-local-stream-passive-socket
,family
,ef
,local-filename
,reuse-address
,backlog
))))
183 ;;; Internet Datagram Socket creation
185 (defun %%make-internet-datagram-socket
(family ef broadcast interface reuse-address
186 local-host local-port remote-host remote-port
)
187 (let ((local-port (ensure-numerical-service local-port
))
188 (remote-port (ensure-numerical-service remote-port
)))
189 (with-close-on-error (socket (create-socket family
:datagram
:active ef
))
190 (when broadcast
(setf (socket-option socket
:broadcast
) t
))
192 (bind-address socket
(ensure-hostname local-host
)
194 :reuse-address reuse-address
)
196 (setf (socket-option socket
:bind-to-device
) interface
)))
197 (when (plusp remote-port
)
198 (connect socket
(ensure-hostname remote-host
)
199 :port remote-port
)))))
201 (defun %make-internet-datagram-socket
(args family ef
)
202 (destructuring-bind (&key broadcast interface
(reuse-address t
)
203 local-host
(local-port 0)
204 (remote-host +any-host
+) (remote-port 0))
206 (%%make-internet-datagram-socket family ef broadcast interface reuse-address
207 local-host local-port remote-host remote-port
)))
209 (define-compiler-macro %make-internet-datagram-socket
(&whole form args family ef
)
210 (with-guard-again-non-list-args-and-destructuring-bind-errors
212 (destructuring-bind (&key broadcast interface
(reuse-address t
)
213 local-host
(local-port 0)
214 (remote-host +any-host
+) (remote-port 0))
216 `(%%make-internet-datagram-socket
,family
,ef
,broadcast
,interface
,reuse-address
217 ,local-host
,local-port
,remote-host
,remote-port
))))
219 ;;; Local Datagram Socket creation
221 (defun %%make-local-datagram-socket
(family ef local-filename remote-filename
)
222 (with-close-on-error (socket (create-socket family
:datagram
:active ef
))
224 (bind-address socket
(ensure-address local-filename
:family
:local
)))
225 (when remote-filename
226 (connect socket
(ensure-address remote-filename
:family
:local
)))))
228 (defun %make-local-datagram-socket
(args family ef
)
229 (destructuring-bind (&key local-filename remote-filename
)
231 (%%make-local-datagram-socket family ef local-filename remote-filename
)))
233 (define-compiler-macro %make-local-datagram-socket
(&whole form args family ef
)
234 (with-guard-again-non-list-args-and-destructuring-bind-errors
236 (destructuring-bind (&key local-filename remote-filename
)
238 `(%%make-local-datagram-socket
,family
,ef
,local-filename
,remote-filename
))))
242 (defun make-socket (&rest args
&key
(family :internet
) (type :stream
)
243 (connect :active
) (ipv6 *ipv6
*)
244 (external-format :default
) &allow-other-keys
)
245 "Creates a socket instance of the appropriate subclass of SOCKET."
246 (check-type family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
247 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
248 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
249 (let ((args (remove-from-plist args
:family
:type
:connect
:external-format
:ipv6
)))
250 (when (eq :ipv4 family
) (setf ipv6 nil
))
252 (when (eq :internet family
) (setf family
+default-inet-family
+))
253 (multiple-value-case ((family type connect
) :test
#'eq
)
254 (((:ipv4
:ipv6
) :stream
:active
)
255 (%make-internet-stream-active-socket args family external-format
))
256 (((:ipv4
:ipv6
) :stream
:passive
)
257 (%make-internet-stream-passive-socket args family external-format
))
258 ((:local
:stream
:active
)
259 (%make-local-stream-active-socket args
:local external-format
))
260 ((:local
:stream
:passive
)
261 (%make-local-stream-passive-socket args
:local external-format
))
262 (((:ipv4
:ipv6
) :datagram
)
263 (%make-internet-datagram-socket args family external-format
))
265 (%make-local-datagram-socket args
:local external-format
))))))
267 (define-compiler-macro make-socket
(&whole form
&rest args
&key
(family :internet
) (type :stream
)
268 (connect :active
) (ipv6 '*ipv6
* ipv6p
)
269 (external-format :default
) &allow-other-keys
)
271 ((and (constantp family
) (constantp type
) (constantp connect
))
272 (check-type family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
273 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
274 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
275 (let ((lower-function
276 (multiple-value-case ((family type connect
) :test
#'eq
)
277 (((:ipv4
:ipv6
:internet
) :stream
:active
) '%make-internet-stream-active-socket
)
278 (((:ipv4
:ipv6
:internet
) :stream
:passive
) '%make-internet-stream-passive-socket
)
279 ((:local
:stream
:active
) '%make-local-stream-active-socket
)
280 ((:local
:stream
:passive
) '%make-local-stream-passive-socket
)
281 (((:ipv4
:ipv6
:internet
) :datagram
) '%make-internet-datagram-socket
)
282 ((:local
:datagram
) '%make-local-datagram-socket
)))
283 (newargs (remove-from-plist args
:family
:type
:connect
:external-format
:ipv6
)))
284 (multiple-value-case (family)
285 (:internet
(setf family
'+default-inet-family
+))
286 (:ipv4
(setf ipv6 nil
)))
287 (let ((expansion `(,lower-function
(list ,@newargs
) ,family
,external-format
)))
288 (if (or ipv6p
(eq :ipv4 family
))
289 `(let ((*ipv6
* ,ipv6
)) ,expansion
)
293 (defmacro with-open-socket
((var &rest args
) &body body
)
294 "VAR is bound to a socket created by passing ARGS to
295 MAKE-SOCKET and BODY is executed as implicit PROGN. The socket
296 is automatically closed upon exit."
297 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
299 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
300 "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
301 ACCEPT-CONNECTION and BODY is executed as implicit PROGN. The socket
302 is automatically closed upon exit."
303 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
305 ;;; MAKE-SOCKET-STREAM
307 (defun get-address-family (fd)
308 (with-sockaddr-storage (ss)
309 (with-socklen (size size-of-sockaddr-storage
)
310 (%getsockname fd ss size
)
311 (foreign-slot-value ss
'sockaddr-storage
'family
))))
313 (defun make-socket-stream (fd &key
(external-format :default
) (errorp t
)
314 input-buffer-size output-buffer-size
)
315 "Creates an active stream socket instance of the appropriate subclass of SOCKET using `FD'.
316 The address family of the sockets is automatically discovered using OS functions. Buffer sizes
317 for the new socket can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'.
318 If `FD' is an invalid socket descriptor and `ERRORP' is not NIL a condition subtype of POSIX-ERROR
319 is signaled, otherwise two values are returned: NIL and the specific condition object."
320 (flet ((%make-socket-stream
()
321 (let ((family (switch ((get-address-family fd
) :test
#'=)
325 (create-socket family
:stream
:active external-format
:fd fd
326 :input-buffer-size input-buffer-size
327 :output-buffer-size output-buffer-size
))))
329 (%make-socket-stream
)
330 (ignore-some-conditions (posix-error)
331 (%make-socket-stream
)))))