1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Socket creation.
6 (in-package :net.sockets
)
8 (defun create-socket (family type connect external-format
&key
9 fd input-buffer-size output-buffer-size
)
10 (make-instance (select-socket-class family type connect
:default
)
11 :address-family family
:file-descriptor fd
12 :external-format external-format
13 :input-buffer-size input-buffer-size
14 :output-buffer-size output-buffer-size
))
16 (define-compiler-macro create-socket
(&whole form family type connect external-format
17 &key fd input-buffer-size output-buffer-size
)
19 ((and (constantp family
) (constantp type
) (constantp connect
))
20 `(make-instance ',(select-socket-class family type connect
:default
)
21 :address-family
,family
:file-descriptor
,fd
22 :external-format
,external-format
23 :input-buffer-size
,input-buffer-size
24 :output-buffer-size
,output-buffer-size
))
27 (defmacro with-close-on-error
((var value
) &body body
)
28 "Bind `VAR' to `VALUE' and execute `BODY' as implicit PROGN.
29 If a non-local exit occurs during the execution of `BODY',
30 call CLOSE with :ABORT T on `VAR'."
32 (unwind-protect-case () ,@body
33 (:abort
(close ,var
:abort t
)))))
35 (defmacro %create-internet-socket
(family &rest args
)
37 (:ipv4
(create-socket :ipv4
,@args
))
38 (:ipv6
(create-socket :ipv6
,@args
))))
40 (defmacro with-guard-against-non-list-args-and-destructuring-bind-errors
41 (form args
&body body
)
43 (handler-case (progn ,@body
)
44 (error (err) `(error ,err
)))
47 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
48 (defun make-first-level-name (family type connect
)
49 (format-symbol :net.sockets
"%~A-~A-~A-~A-~A" :make family type connect
:socket
)))
51 (defmacro define-socket-creator
((socket-family socket-type socket-connect
)
52 (family ef key
&rest args
) &body body
)
53 (assert (eql '&key key
))
54 (flet ((maybe-quote-default-value (arg)
55 (cond ((symbolp arg
) arg
)
56 ((consp arg
) (list (first arg
) `(quote ,(second arg
))))))
58 (cond ((symbolp arg
) arg
)
59 ((consp arg
) (first arg
))))
61 `(list (quote ,(car form
)) ,@(cdr form
))))
62 (let* ((arg-names (mapcar #'arg-name args
))
63 (first-level-function (make-first-level-name socket-family socket-type socket-connect
))
64 (second-level-function (format-symbol t
"%~A" first-level-function
))
65 (first-level-body `(,second-level-function family ef
,@arg-names
)))
67 (declaim (inline ,second-level-function
))
68 (defun ,second-level-function
(,family
,ef
,@arg-names
) ,@body
)
69 (defun ,first-level-function
(arguments family ef
)
70 (destructuring-bind (&key
,@args
) arguments
,first-level-body
))
71 (define-compiler-macro ,first-level-function
(&whole form arguments family ef
)
72 (with-guard-against-non-list-args-and-destructuring-bind-errors
74 ;; Must quote default values in order for them not to be evaluated
75 ;; in the compilation environment
76 (destructuring-bind (&key
,@(mapcar #'maybe-quote-default-value args
))
78 ,(quotify first-level-body
))))))))
80 ;;; Internet Stream Active Socket creation
82 (defun %%init-internet-stream-active-socket
(socket keepalive nodelay reuse-address
83 local-host local-port remote-host remote-port
)
84 (let ((local-port (ensure-numerical-service local-port
))
85 (remote-port (ensure-numerical-service remote-port
)))
86 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
87 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
88 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
90 (bind-address socket
(ensure-hostname local-host
)
92 :reuse-address reuse-address
))
93 (when (plusp remote-port
)
94 (connect socket
(ensure-hostname remote-host
)
98 (define-socket-creator (:internet
:stream
:active
)
99 (family ef
&key keepalive nodelay
(reuse-address t
)
100 local-host
(local-port 0)
101 (remote-host +any-host
+) (remote-port 0)
102 input-buffer-size output-buffer-size
)
103 (with-close-on-error (socket (%create-internet-socket family
:stream
:active ef
104 :input-buffer-size input-buffer-size
105 :output-buffer-size output-buffer-size
))
106 (%%init-internet-stream-active-socket socket keepalive nodelay reuse-address
107 local-host local-port remote-host remote-port
)))
109 ;;; Internet Stream Passive Socket creation
111 (defun %%init-internet-stream-passive-socket
(socket interface reuse-address
112 local-host local-port backlog
)
113 (let ((local-port (ensure-numerical-service local-port
)))
116 (setf (socket-option socket
:bind-to-device
) interface
))
117 (bind-address socket
(ensure-hostname local-host
)
119 :reuse-address reuse-address
)
120 (listen-on socket
:backlog backlog
)))
123 (define-socket-creator (:internet
:stream
:passive
)
124 (family ef
&key interface
(reuse-address t
)
125 (local-host +any-host
+) (local-port 0)
126 (backlog *default-backlog-size
*))
127 (with-close-on-error (socket (%create-internet-socket family
:stream
:passive ef
))
128 (%%init-internet-stream-passive-socket socket interface reuse-address
129 local-host local-port backlog
)))
131 ;;; Local Stream Active Socket creation
133 (defun %%init-local-stream-active-socket
(socket local-filename remote-filename
)
134 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
136 (bind-address socket
(ensure-address local-filename
:family
:local
)))
137 (when remote-filename
138 (connect socket
(ensure-address remote-filename
:family
:local
)))
141 (define-socket-creator (:local
:stream
:active
)
142 (family ef
&key local-filename remote-filename
143 input-buffer-size output-buffer-size
)
144 (declare (ignore family
))
145 (with-close-on-error (socket (create-socket :local
:stream
:active ef
146 :input-buffer-size input-buffer-size
147 :output-buffer-size output-buffer-size
))
148 (%%init-local-stream-active-socket socket local-filename remote-filename
)))
150 ;;; Local Stream Passive Socket creation
152 (defun %%init-local-stream-passive-socket
(socket local-filename reuse-address backlog
)
154 (bind-address socket
(ensure-address local-filename
:family
:local
)
155 :reuse-address reuse-address
)
156 (listen-on socket
:backlog backlog
))
159 (define-socket-creator (:local
:stream
:passive
)
160 (family ef
&key local-filename
(reuse-address t
)
161 (backlog *default-backlog-size
*))
162 (declare (ignore family
))
163 (with-close-on-error (socket (create-socket :local
:stream
:passive ef
))
164 (%%init-local-stream-passive-socket socket local-filename reuse-address backlog
)))
166 ;;; Internet Datagram Socket creation
168 (defun %%init-internet-datagram-active-socket
(socket broadcast interface reuse-address
169 local-host local-port remote-host remote-port
)
170 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
171 (let ((local-port (ensure-numerical-service local-port
))
172 (remote-port (ensure-numerical-service remote-port
)))
173 (when broadcast
(setf (socket-option socket
:broadcast
) t
))
175 (bind-address socket
(ensure-hostname local-host
)
177 :reuse-address reuse-address
)
179 (setf (socket-option socket
:bind-to-device
) interface
)))
180 (when (plusp remote-port
)
181 (connect socket
(ensure-hostname remote-host
)
185 (define-socket-creator (:internet
:datagram
:active
)
186 (family ef
&key broadcast interface
(reuse-address t
)
187 local-host
(local-port 0)
188 (remote-host +any-host
+) (remote-port 0))
189 (with-close-on-error (socket (%create-internet-socket family
:datagram
:active ef
))
190 (%%init-internet-datagram-active-socket socket broadcast interface reuse-address
191 local-host local-port remote-host remote-port
)))
193 ;;; Local Datagram Socket creation
195 (defun %%init-local-datagram-active-socket
(socket local-filename remote-filename
)
196 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
198 (bind-address socket
(ensure-address local-filename
:family
:local
)))
199 (when remote-filename
200 (connect socket
(ensure-address remote-filename
:family
:local
)))
203 (define-socket-creator (:local
:datagram
:active
)
204 (family ef
&key local-filename remote-filename
)
205 (declare (ignore family
))
206 (with-close-on-error (socket (create-socket :local
:datagram
:active ef
))
207 (%%init-local-datagram-active-socket socket local-filename remote-filename
)))
211 (defun make-socket (&rest args
&key
(address-family :internet
) (type :stream
)
212 (connect :active
) (ipv6 *ipv6
*)
213 (external-format :default
) &allow-other-keys
)
214 "Creates a socket instance of the appropriate subclass of SOCKET."
215 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
216 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
217 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
218 (let ((args (remove-from-plist args
:address-family
:type
:connect
:external-format
:ipv6
)))
219 (when (eq :ipv4 address-family
) (setf ipv6 nil
))
221 (when (eq :internet address-family
) (setf address-family
+default-inet-address-family
+))
222 (multiple-value-case ((address-family type connect
))
223 (((:ipv4
:ipv6
) :stream
:active
)
224 (%make-internet-stream-active-socket args address-family external-format
))
225 (((:ipv4
:ipv6
) :stream
:passive
)
226 (%make-internet-stream-passive-socket args address-family external-format
))
227 ((:local
:stream
:active
)
228 (%make-local-stream-active-socket args
:local external-format
))
229 ((:local
:stream
:passive
)
230 (%make-local-stream-passive-socket args
:local external-format
))
231 (((:ipv4
:ipv6
) :datagram
)
232 (%make-internet-datagram-active-socket args address-family external-format
))
234 (%make-local-datagram-active-socket args
:local external-format
))))))
236 (define-compiler-macro make-socket
(&whole form
&rest args
&key
(address-family :internet
) (type :stream
)
237 (connect :active
) (ipv6 '*ipv6
* ipv6p
)
238 (external-format :default
) &allow-other-keys
)
240 ((and (constantp address-family
) (constantp type
) (constantp connect
))
241 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
242 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
243 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
244 (let* ((family (if (member address-family
'(:ipv4
:ipv6
)) :internet address-family
))
245 (lower-function (make-first-level-name family type connect
))
246 (newargs (remove-from-plist args
:address-family
:type
:connect
:external-format
:ipv6
)))
248 (:internet
(setf address-family
'+default-inet-address-family
+))
249 (:ipv4
(setf ipv6 nil ipv6p t
)))
250 (let ((expansion `(,lower-function
(list ,@newargs
) ,address-family
,external-format
)))
251 (if ipv6p
`(let ((*ipv6
* ,ipv6
)) ,expansion
) expansion
))))
254 (defmacro with-open-socket
((var &rest args
) &body body
)
255 "VAR is bound to a socket created by passing ARGS to
256 MAKE-SOCKET and BODY is executed as implicit PROGN. The socket
257 is automatically closed upon exit."
258 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
260 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
261 "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
262 ACCEPT-CONNECTION and BODY is executed as implicit PROGN. The socket
263 is automatically closed upon exit."
264 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
266 ;;; MAKE-SOCKET-FROM-FD
268 ;;; FIXME: must come up with a way to find out
269 ;;; whether a socket is active or passive
270 (defun make-socket-from-fd (fd &key
(connect :active
) (external-format :default
)
271 input-buffer-size output-buffer-size
)
272 "Creates an socket instance of the appropriate subclass of SOCKET using `FD'.
273 The connection type of the socket must be specified(:ACTIVE or :PASSIVE).
274 The address family and type of the socket is automatically discovered using OS functions. Buffer sizes
275 for the new socket can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
276 (flet ((%get-address-family
(fd)
277 (with-sockaddr-storage-and-socklen (ss size
)
278 (%getsockname fd ss size
)
279 (eswitch ((foreign-slot-value ss
'sockaddr-storage
'family
) :test
#'=)
284 (eswitch ((get-socket-option-int fd sol-socket so-type
) :test
#'=)
285 (sock-stream :stream
)
286 (sock-dgram :datagram
))))
287 (create-socket (%get-address-family fd
)
289 connect external-format
:fd fd
290 :input-buffer-size input-buffer-size
291 :output-buffer-size output-buffer-size
)))
295 (defun make-socket-pair (&key
(type :stream
) (protocol :default
) (external-format :default
)
296 input-buffer-size output-buffer-size
)
297 "Creates a pair of sockets connected to each other.
298 The socket type can be either :STREAM or :DATAGRAM. Currently OSes can only create :LOCAL sockets this way.
299 Buffer sizes for the new sockets can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
300 (flet ((%make-socket-pair
(fd)
301 (make-socket-from-fd fd
:external-format external-format
302 :input-buffer-size input-buffer-size
303 :output-buffer-size output-buffer-size
)))
304 (multiple-value-bind (fd1 fd2
)
305 (multiple-value-call #'%socketpair
306 (translate-make-socket-keywords-to-constants :local type protocol
))
307 (values (%make-socket-pair fd1
)
308 (%make-socket-pair fd2
)))))
310 ;;; SEND/RECEIVE-FILE-DESCRIPTOR
312 (defun call-with-buffers-for-fd-passing (fn)
313 (with-foreign-object (msg 'msghdr
)
314 (bzero msg size-of-msghdr
)
315 (with-foreign-pointer (buffer #.
(%cmsg-space size-of-int
) buffer-size
)
316 (bzero buffer buffer-size
)
317 (with-foreign-slots ((control controllen
) msg msghdr
)
319 controllen buffer-size
)
320 (let ((cmsg (%cmsg-firsthdr msg
)))
321 (with-foreign-slots ((len level type
) cmsg cmsghdr
)
322 (setf len
(%cmsg-len size-of-int
)
325 (funcall fn msg cmsg
)))))))
327 (defmacro with-buffers-for-fd-passing
((msg-var cmsg-var
) &body body
)
328 `(call-with-buffers-for-fd-passing (lambda (,msg-var
,cmsg-var
) ,@body
)))
330 (defmethod send-file-descriptor ((socket local-socket
) file-descriptor
)
331 (with-buffers-for-fd-passing (msg cmsg
)
332 (let ((data (%cmsg-data cmsg
)))
333 (setf (mem-aref data
:int
) file-descriptor
)
334 (%sendmsg
(fd-of socket
) msg
0)
337 (defmethod receive-file-descriptor ((socket local-socket
))
338 (with-buffers-for-fd-passing (msg cmsg
)
339 (let ((data (%cmsg-data cmsg
)))
340 (%recvmsg
(fd-of socket
) msg
0)
341 (mem-aref data
:int
))))