1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Socket creation.
6 (in-package :iolib.sockets
)
8 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
9 (defparameter *socket-type-map
*
10 '(((:ipv4
:stream
:active
) . socket-stream-internet-active
)
11 ((:ipv6
:stream
:active
) . socket-stream-internet-active
)
12 ((:ipv4
:stream
:passive
) . socket-stream-internet-passive
)
13 ((:ipv6
:stream
:passive
) . socket-stream-internet-passive
)
14 ((:local
:stream
:active
) . socket-stream-local-active
)
15 ((:local
:stream
:passive
) . socket-stream-local-passive
)
16 ((:local
:datagram nil
) . socket-datagram-local
)
17 ((:ipv4
:datagram nil
) . socket-datagram-internet
)
18 ((:ipv6
:datagram nil
) . socket-datagram-internet
)
19 ((:ipv4
:raw nil
) . socket-raw-internet
)))
21 (defun select-socket-class (address-family type connect
)
22 (or (loop :for
((sock-family sock-type sock-connect
) . class
)
24 :when
(and (eql sock-family address-family
)
26 (if sock-connect
(eql sock-connect connect
) t
))
28 (error "No socket class found !!"))))
30 (defun create-socket (family type protocol
31 &rest args
&key connect fd
&allow-other-keys
)
32 (apply #'make-instance
(select-socket-class family type connect
)
33 :address-family family
36 (remove-from-plist args
:connect
)))
38 (define-compiler-macro create-socket
(&whole form
&environment env
40 &rest args
&key connect fd
&allow-other-keys
)
42 ((and (constantp family env
) (constantp type env
) (constantp connect env
))
43 `(make-instance ',(select-socket-class family type connect
)
45 :address-family
,family
47 ,@(remove-from-plist args
:connect
)))
50 (defmacro with-close-on-error
((var value
) &body body
)
51 "Bind `VAR' to `VALUE' and execute `BODY' as implicit PROGN.
52 If a non-local exit occurs during the execution of `BODY',
53 call CLOSE with :ABORT T on `VAR'."
55 (unwind-protect-case () ,@body
56 (:abort
(close ,var
:abort t
)))))
58 (defmacro %create-internet-socket
(family &rest args
)
60 (:ipv4
(create-socket :ipv4
,@args
))
61 (:ipv6
(create-socket :ipv6
,@args
))))
63 (defmacro with-guard-against-non-list-args-and-destructuring-bind-errors
64 (form args
&body body
)
66 (handler-case (progn ,@body
)
67 (error (err) `(error ,err
)))
70 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
71 (defun make-first-level-name (family type connect
)
72 (if (eql :stream type
)
73 (format-symbol :iolib.sockets
"%~A/~A-~A-~A" :make-socket family type connect
)
74 (format-symbol :iolib.sockets
"%~A/~A-~A" :make-socket family type
))))
76 (defmacro define-socket-creator
((socket-family socket-type
&optional socket-connect
)
77 (family protocol key
&rest args
) &body body
)
78 (assert (eql '&key key
))
79 (flet ((maybe-quote-default-value (arg)
80 (cond ((symbolp arg
) arg
)
81 ((consp arg
) (list (first arg
) `(quote ,(second arg
))))))
83 (cond ((symbolp arg
) arg
)
84 ((consp arg
) (first arg
))))
86 `(list (quote ,(car form
)) ,@(cdr form
))))
87 (let* ((arg-names (mapcar #'arg-name args
))
88 (first-level-function (make-first-level-name socket-family socket-type socket-connect
))
89 (second-level-function (format-symbol t
"%~A" first-level-function
))
90 (first-level-body `(,second-level-function family protocol
,@arg-names
)))
92 (declaim (inline ,second-level-function
))
93 (defun ,second-level-function
(,family
,protocol
,@arg-names
) ,@body
)
94 (defun ,first-level-function
(arguments family protocol
)
95 (destructuring-bind (&key
,@args
) arguments
,first-level-body
))
96 (define-compiler-macro ,first-level-function
(&whole form arguments family protocol
)
97 (with-guard-against-non-list-args-and-destructuring-bind-errors
99 ;; Must quote default values in order for them not to be evaluated
100 ;; in the compilation environment
101 (destructuring-bind (&key
,@(mapcar #'maybe-quote-default-value args
))
103 ,(quotify first-level-body
))))))))
106 ;;; Internet Stream Active Socket creation
108 (defun %%init-socket
/internet-stream-active
(socket keepalive nodelay reuse-address
109 local-host local-port remote-host remote-port
)
110 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
111 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
112 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
114 (bind-address socket
(ensure-hostname local-host
)
116 :reuse-address reuse-address
))
118 (connect socket
(ensure-hostname remote-host
)
122 (define-socket-creator (:internet
:stream
:active
)
123 (family protocol
&key external-format
124 keepalive nodelay
(reuse-address t
)
125 local-host local-port remote-host remote-port
126 input-buffer-size output-buffer-size
)
127 (with-close-on-error (socket (%create-internet-socket family
:stream protocol
129 :external-format external-format
130 :input-buffer-size input-buffer-size
131 :output-buffer-size output-buffer-size
))
132 (%%init-socket
/internet-stream-active socket keepalive nodelay reuse-address
133 local-host
(or local-port
0) remote-host remote-port
)))
136 ;;; Internet Stream Passive Socket creation
138 (defun %%init-socket
/internet-stream-passive
(socket interface reuse-address
139 local-host local-port backlog
)
142 (setf (socket-option socket
:bind-to-device
) interface
))
143 (bind-address socket
(ensure-hostname local-host
)
145 :reuse-address reuse-address
)
146 (listen-on socket
:backlog backlog
))
149 (define-socket-creator (:internet
:stream
:passive
)
150 (family protocol
&key external-format
151 interface
(reuse-address t
)
152 local-host local-port backlog
)
153 (with-close-on-error (socket (%create-internet-socket family
:stream protocol
155 :external-format external-format
))
156 (%%init-socket
/internet-stream-passive socket interface reuse-address
157 local-host
(or local-port
0)
158 (or backlog
*default-backlog-size
*))))
161 ;;; Local Stream Active Socket creation
163 (defun %%init-socket
/local-stream-active
(socket local-filename remote-filename
)
164 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
166 (bind-address socket
(ensure-address local-filename
:family
:local
)))
167 (when remote-filename
168 (connect socket
(ensure-address remote-filename
:family
:local
)))
171 (define-socket-creator (:local
:stream
:active
)
172 (family protocol
&key external-format local-filename remote-filename
173 input-buffer-size output-buffer-size
)
174 (with-close-on-error (socket (create-socket family
:stream protocol
176 :external-format external-format
177 :input-buffer-size input-buffer-size
178 :output-buffer-size output-buffer-size
))
179 (%%init-socket
/local-stream-active socket local-filename remote-filename
)))
182 ;;; Local Stream Passive Socket creation
184 (defun %%init-socket
/local-stream-passive
(socket local-filename reuse-address backlog
)
186 (bind-address socket
(ensure-address local-filename
:family
:local
)
187 :reuse-address reuse-address
)
188 (listen-on socket
:backlog backlog
))
191 (define-socket-creator (:local
:stream
:passive
)
192 (family protocol
&key external-format local-filename
(reuse-address t
) backlog
)
193 (with-close-on-error (socket (create-socket family
:stream protocol
195 :external-format external-format
))
196 (%%init-socket
/local-stream-passive socket local-filename reuse-address
197 (or backlog
*default-backlog-size
*))))
200 ;;; Internet Datagram Socket creation
202 (defun %%init-socket
/internet-datagram
(socket broadcast interface reuse-address
203 local-host local-port remote-host remote-port
)
204 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
205 (when broadcast
(setf (socket-option socket
:broadcast
) t
))
207 (bind-address socket
(ensure-hostname local-host
)
209 :reuse-address reuse-address
)
211 (setf (socket-option socket
:bind-to-device
) interface
)))
213 (connect socket
(ensure-hostname remote-host
)
217 (define-socket-creator (:internet
:datagram
)
218 (family protocol
&key broadcast interface
(reuse-address t
)
219 local-host local-port remote-host remote-port
)
220 (with-close-on-error (socket (%create-internet-socket family
:datagram protocol
))
221 (%%init-socket
/internet-datagram socket broadcast interface reuse-address
222 local-host
(or local-port
0)
223 remote-host
(or remote-port
0))))
226 ;;; Local Datagram Socket creation
228 (defun %%init-socket
/local-datagram
(socket local-filename remote-filename
)
229 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
231 (bind-address socket
(ensure-address local-filename
:family
:local
)))
232 (when remote-filename
233 (connect socket
(ensure-address remote-filename
:family
:local
)))
236 (define-socket-creator (:local
:datagram
)
237 (family protocol
&key local-filename remote-filename
)
238 (with-close-on-error (socket (create-socket family
:datagram protocol
))
239 (%%init-socket
/local-datagram socket local-filename remote-filename
)))
242 ;;; Raw Socket creation
244 (defun %%init-socket
/internet-raw
(socket include-headers
)
245 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
246 (setf (socket-option socket
:ip-header-include
) include-headers
)
249 (define-socket-creator (:internet
:raw
)
250 (family protocol
&key include-headers
)
251 (with-close-on-error (socket (create-socket family
:raw protocol
))
252 (%%init-socket
/internet-raw socket include-headers
)))
257 (defmethod make-socket (&rest args
&key
(address-family :internet
) (type :stream
) (protocol :default
)
258 (connect :active
) (ipv6 *ipv6
*) &allow-other-keys
)
259 (when (eql :file address-family
) (setf address-family
:local
))
260 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL(or :FILE), :IPV4 or :IPV6")
261 (check-type type
(member :stream
:datagram
:raw
) "either :STREAM, :DATAGRAM or :RAW")
262 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
263 (let ((args (remove-from-plist args
:address-family
:type
:protocol
:connect
:ipv6
)))
264 (when (eql :ipv4 address-family
) (setf ipv6 nil
))
266 (when (eql :internet address-family
) (setf address-family
+default-inet-address-family
+))
267 (multiple-value-case ((address-family type connect
))
268 ((:ipv4
:stream
:active
)
269 (%make-socket
/internet-stream-active args
:ipv4
:default
))
270 ((:ipv6
:stream
:active
)
271 (%make-socket
/internet-stream-active args
:ipv6
:default
))
272 ((:ipv4
:stream
:passive
)
273 (%make-socket
/internet-stream-passive args
:ipv4
:default
))
274 ((:ipv6
:stream
:passive
)
275 (%make-socket
/internet-stream-passive args
:ipv6
:default
))
276 ((:local
:stream
:active
)
277 (%make-socket
/local-stream-active args
:local
:default
))
278 ((:local
:stream
:passive
)
279 (%make-socket
/local-stream-passive args
:local
:default
))
281 (%make-socket
/internet-datagram args
:ipv4
:default
))
283 (%make-socket
/internet-datagram args
:ipv6
:default
))
285 (%make-socket
/local-datagram args
:local
:default
))
287 (%make-socket
/internet-raw args
:ipv4 protocol
))))))
289 (define-compiler-macro make-socket
(&whole form
&environment env
&rest args
290 &key
(address-family :internet
) (type :stream
) (protocol :default
)
291 (connect :active
) (ipv6 '*ipv6
* ipv6p
) &allow-other-keys
)
292 (when (eql :file address-family
) (setf address-family
:local
))
294 ((and (constantp address-family env
) (constantp type env
) (constantp connect env
))
295 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL(or :FILE), :IPV4 or :IPV6")
296 (check-type type
(member :stream
:datagram
:raw
) "either :STREAM, :DATAGRAM or :RAW")
297 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
298 (let* ((family (if (member address-family
'(:ipv4
:ipv6
)) :internet address-family
))
299 (lower-function (make-first-level-name family type connect
))
300 (args (remove-from-plist args
:address-family
:type
:protocol
:connect
:ipv6
)))
302 (:internet
(setf address-family
'+default-inet-address-family
+))
303 (:ipv4
(setf ipv6 nil ipv6p t
)))
304 (let ((expansion `(,lower-function
(list ,@args
) ,address-family
,protocol
)))
305 (if ipv6p
`(let ((*ipv6
* ,ipv6
)) ,expansion
) expansion
))))
308 (defmacro with-open-socket
((var &rest args
) &body body
)
309 "Bind VAR to a socket created by passing ARGS to MAKE-SOCKET and execute BODY as implicit PROGN.
310 The socket is automatically closed upon exit."
311 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
313 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
314 "Bind VAR to a socket created by passing PASSIVE-SOCKET and ARGS to ACCEPT-CONNECTION and execute BODY as implicit PROGN.
315 The socket is automatically closed upon exit."
316 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
319 ;;; MAKE-SOCKET-FROM-FD
321 ;;; FIXME: must come up with a way to find out
322 ;;; whether a socket is active or passive
323 (defmethod make-socket-from-fd ((fd integer
) &key
(dup t
) (connect :active
) (external-format :default
)
324 input-buffer-size output-buffer-size
)
325 (flet ((%get-address-family
(fd)
326 (with-sockaddr-storage-and-socklen (ss size
)
327 (%getsockname fd ss size
)
328 (eswitch ((foreign-slot-value ss
'sockaddr-storage
'family
) :test
#'=)
333 (eswitch ((get-socket-option-int fd sol-socket so-type
) :test
#'=)
334 (sock-stream :stream
)
335 (sock-dgram :datagram
)
337 (create-socket (%get-address-family fd
)
343 :external-format external-format
344 :input-buffer-size input-buffer-size
345 :output-buffer-size output-buffer-size
)))
350 (defmethod make-socket-pair (&key
(type :stream
) (protocol :default
) (external-format :default
)
351 input-buffer-size output-buffer-size
)
352 (flet ((%make-socket-pair
(fd)
353 (make-socket-from-fd fd
:dup nil
354 :external-format external-format
355 :input-buffer-size input-buffer-size
356 :output-buffer-size output-buffer-size
)))
357 (multiple-value-bind (fd1 fd2
)
358 (multiple-value-call #'%socketpair
359 (translate-make-socket-keywords-to-constants :local type protocol
))
360 (values (%make-socket-pair fd1
)
361 (%make-socket-pair fd2
)))))
364 ;;; SEND/RECEIVE-FILE-DESCRIPTOR
366 (defun call-with-buffers-for-fd-passing (fn)
367 (with-foreign-object (msg 'msghdr
)
368 (isys:bzero msg
(isys:sizeof
'msghdr
))
369 (with-foreign-pointer (buffer #.
(isys:cmsg.space
(isys:sizeof
:int
))
371 (isys:bzero buffer buffer-size
)
372 (with-foreign-slots ((control controllen
) msg msghdr
)
374 controllen buffer-size
)
375 (let ((cmsg (isys:cmsg.firsthdr msg
)))
376 (with-foreign-slots ((len level type
) cmsg cmsghdr
)
377 (setf len
(isys:cmsg.len
(isys:sizeof
:int
))
380 (funcall fn msg cmsg
)))))))
382 (defmacro with-buffers-for-fd-passing
((msg-var cmsg-var
) &body body
)
383 `(call-with-buffers-for-fd-passing (lambda (,msg-var
,cmsg-var
) ,@body
)))
385 (defmethod send-file-descriptor ((socket local-socket
) file-descriptor
)
386 (with-buffers-for-fd-passing (msg cmsg
)
387 (let ((data (isys:cmsg.data cmsg
)))
388 (setf (mem-aref data
:int
) file-descriptor
)
389 (%sendmsg
(fd-of socket
) msg
0)
392 (defmethod receive-file-descriptor ((socket local-socket
))
393 (with-buffers-for-fd-passing (msg cmsg
)
394 (let ((data (isys:cmsg.data cmsg
)))
395 (%recvmsg
(fd-of socket
) msg
0)
396 (mem-aref data
:int
))))