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 ((:netlink
:raw nil
) . socket-raw-netlink
)))
23 (defun select-socket-class (address-family type connect
)
24 (or (loop :for
((sock-family sock-type sock-connect
) . class
)
26 :when
(and (eql sock-family address-family
)
28 (if sock-connect
(eql sock-connect connect
) t
))
30 (error "No socket class found !!"))))
32 (defun create-socket (family type protocol
33 &rest args
&key connect fd
&allow-other-keys
)
34 (apply #'make-instance
(select-socket-class family type connect
)
35 :address-family family
38 (remove-from-plist args
:connect
)))
40 (define-compiler-macro create-socket
(&whole form
&environment env
42 &rest args
&key connect fd
&allow-other-keys
)
44 ((and (constantp family env
) (constantp type env
) (constantp connect env
))
45 `(make-instance ',(select-socket-class family type connect
)
47 :address-family
,family
49 ,@(remove-from-plist args
:connect
)))
52 (defmacro with-close-on-error
((var value
) &body body
)
53 "Bind `VAR' to `VALUE' and execute `BODY' as implicit PROGN.
54 If a non-local exit occurs during the execution of `BODY',
55 call CLOSE with :ABORT T on `VAR'."
57 (unwind-protect-case () ,@body
58 (:abort
(close ,var
:abort t
)))))
60 (defmacro %create-internet-socket
(family &rest args
)
62 (:ipv4
(create-socket :ipv4
,@args
))
63 (:ipv6
(create-socket :ipv6
,@args
))))
65 (defmacro with-guard-against-non-list-args-and-destructuring-bind-errors
66 (form args
&body body
)
68 (handler-case (progn ,@body
)
69 (error (err) `(error ,err
)))
72 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
73 (defun make-first-level-name (family type connect
)
74 (if (eql :stream type
)
75 (format-symbol :iolib.sockets
"%~A/~A-~A-~A" :make-socket family type connect
)
76 (format-symbol :iolib.sockets
"%~A/~A-~A" :make-socket family type
))))
78 (defmacro define-socket-creator
((socket-family socket-type
&optional socket-connect
)
79 (family protocol key
&rest args
) &body body
)
80 (assert (eql '&key key
))
81 (flet ((maybe-quote-default-value (arg)
82 (cond ((symbolp arg
) arg
)
83 ((consp arg
) (list (first arg
) `(quote ,(second arg
))))))
85 (cond ((symbolp arg
) arg
)
86 ((consp arg
) (first arg
))))
88 `(list (quote ,(car form
)) ,@(cdr form
))))
89 (let* ((arg-names (mapcar #'arg-name args
))
90 (first-level-function (make-first-level-name socket-family socket-type socket-connect
))
91 (second-level-function (format-symbol t
"%~A" first-level-function
))
92 (first-level-body `(,second-level-function family protocol
,@arg-names
)))
94 (declaim (inline ,second-level-function
))
95 (defun ,second-level-function
(,family
,protocol
,@arg-names
) ,@body
)
96 (defun ,first-level-function
(arguments family protocol
)
97 (destructuring-bind (&key
,@args
) arguments
,first-level-body
))
98 (define-compiler-macro ,first-level-function
(&whole form arguments family protocol
)
99 (with-guard-against-non-list-args-and-destructuring-bind-errors
101 ;; Must quote default values in order for them not to be evaluated
102 ;; in the compilation environment
103 (destructuring-bind (&key
,@(mapcar #'maybe-quote-default-value args
))
105 ,(quotify first-level-body
))))))))
108 ;;; Internet Stream Active Socket creation
110 (defun %%init-socket
/internet-stream-active
(socket keepalive nodelay reuse-address
111 local-host local-port remote-host remote-port
)
112 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
113 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
114 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
116 (bind-address socket
(ensure-hostname local-host
)
118 :reuse-address reuse-address
))
120 (connect socket
(ensure-hostname remote-host
)
124 (define-socket-creator (:internet
:stream
:active
)
125 (family protocol
&key external-format
126 keepalive nodelay
(reuse-address t
)
127 local-host local-port remote-host remote-port
128 input-buffer-size output-buffer-size
)
129 (with-close-on-error (socket (%create-internet-socket family
:stream protocol
131 :external-format external-format
132 :input-buffer-size input-buffer-size
133 :output-buffer-size output-buffer-size
))
134 (%%init-socket
/internet-stream-active socket keepalive nodelay reuse-address
135 local-host
(or local-port
0) remote-host remote-port
)))
138 ;;; Internet Stream Passive Socket creation
140 (defun %%init-socket
/internet-stream-passive
(socket interface reuse-address
141 local-host local-port backlog
)
144 (setf (socket-option socket
:bind-to-device
) interface
))
145 (bind-address socket
(ensure-hostname local-host
)
147 :reuse-address reuse-address
)
148 (listen-on socket
:backlog backlog
))
151 (define-socket-creator (:internet
:stream
:passive
)
152 (family protocol
&key external-format
153 interface
(reuse-address t
)
154 local-host local-port backlog
)
155 (with-close-on-error (socket (%create-internet-socket family
:stream protocol
157 :external-format external-format
))
158 (%%init-socket
/internet-stream-passive socket interface reuse-address
159 local-host
(or local-port
0)
160 (or backlog
*default-backlog-size
*))))
163 ;;; Local Stream Active Socket creation
165 (defun %%init-socket
/local-stream-active
(socket local-filename remote-filename
)
166 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
168 (bind-address socket
(ensure-address local-filename
:family
:local
)))
169 (when remote-filename
170 (connect socket
(ensure-address remote-filename
:family
:local
)))
173 (define-socket-creator (:local
:stream
:active
)
174 (family protocol
&key external-format local-filename remote-filename
175 input-buffer-size output-buffer-size
)
176 (with-close-on-error (socket (create-socket family
:stream protocol
178 :external-format external-format
179 :input-buffer-size input-buffer-size
180 :output-buffer-size output-buffer-size
))
181 (%%init-socket
/local-stream-active socket local-filename remote-filename
)))
184 ;;; Local Stream Passive Socket creation
186 (defun %%init-socket
/local-stream-passive
(socket local-filename reuse-address backlog
)
188 (bind-address socket
(ensure-address local-filename
:family
:local
)
189 :reuse-address reuse-address
)
190 (listen-on socket
:backlog backlog
))
193 (define-socket-creator (:local
:stream
:passive
)
194 (family protocol
&key external-format local-filename
(reuse-address t
) backlog
)
195 (with-close-on-error (socket (create-socket family
:stream protocol
197 :external-format external-format
))
198 (%%init-socket
/local-stream-passive socket local-filename reuse-address
199 (or backlog
*default-backlog-size
*))))
202 ;;; Internet Datagram Socket creation
204 (defun %%init-socket
/internet-datagram
(socket broadcast interface reuse-address
205 local-host local-port remote-host remote-port
)
206 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
207 (when broadcast
(setf (socket-option socket
:broadcast
) t
))
209 (bind-address socket
(ensure-hostname local-host
)
211 :reuse-address reuse-address
)
213 (setf (socket-option socket
:bind-to-device
) interface
)))
215 (connect socket
(ensure-hostname remote-host
)
219 (define-socket-creator (:internet
:datagram
)
220 (family protocol
&key broadcast interface
(reuse-address t
)
221 local-host local-port remote-host remote-port
)
222 (with-close-on-error (socket (%create-internet-socket family
:datagram protocol
))
223 (%%init-socket
/internet-datagram socket broadcast interface reuse-address
224 local-host
(or local-port
0)
225 remote-host
(or remote-port
0))))
228 ;;; Local Datagram Socket creation
230 (defun %%init-socket
/local-datagram
(socket local-filename remote-filename
)
231 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
233 (bind-address socket
(ensure-address local-filename
:family
:local
)))
234 (when remote-filename
235 (connect socket
(ensure-address remote-filename
:family
:local
)))
238 (define-socket-creator (:local
:datagram
)
239 (family protocol
&key local-filename remote-filename
)
240 (with-close-on-error (socket (create-socket family
:datagram protocol
))
241 (%%init-socket
/local-datagram socket local-filename remote-filename
)))
244 ;;; Raw Socket creation
246 (defun %%init-socket
/internet-raw
(socket include-headers
)
247 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
248 (setf (socket-option socket
:ip-header-include
) include-headers
)
251 (define-socket-creator (:internet
:raw
)
252 (family protocol
&key include-headers
)
253 (with-close-on-error (socket (create-socket family
:raw protocol
))
254 (%%init-socket
/internet-raw socket include-headers
)))
257 ;;; Netlink Socket creation
260 (defun %%init-socket
/netlink-raw
(socket local-port multicast-groups
)
263 (make-instance 'netlink-address
264 :multicast-groups multicast-groups
)
269 (define-socket-creator (:netlink
:raw
)
270 (family protocol
&key
(local-port 0) (multicast-groups 0))
271 (with-close-on-error (socket (create-socket family
:raw protocol
))
272 (%%init-socket
/netlink-raw socket local-port multicast-groups
)))
275 (define-socket-creator (:netlink
:raw
)
276 (family protocol
&key
(local-port 0) (multicast-groups 0))
277 (declare (ignore family protocol local-port multicast-groups
))
278 (error 'socket-address-family-not-supported-error
))
283 (defmethod make-socket (&rest args
&key
(address-family :internet
) (type :stream
) (protocol :default
)
284 (connect :active
) (ipv6 *ipv6
*) &allow-other-keys
)
285 (when (eql :file address-family
) (setf address-family
:local
))
286 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
:netlink
)
287 "one of :INTERNET, :LOCAL(or :FILE), :IPV4, :IPV6 or :NETLINK")
288 (check-type type
(member :stream
:datagram
:raw
) "either :STREAM, :DATAGRAM or :RAW")
289 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
290 (let ((args (remove-from-plist args
:address-family
:type
:protocol
:connect
:ipv6
)))
291 (when (eql :ipv4 address-family
) (setf ipv6 nil
))
293 (when (eql :internet address-family
) (setf address-family
+default-inet-address-family
+))
294 (multiple-value-case ((address-family type connect
))
295 ((:ipv4
:stream
:active
)
296 (%make-socket
/internet-stream-active args
:ipv4
:default
))
297 ((:ipv6
:stream
:active
)
298 (%make-socket
/internet-stream-active args
:ipv6
:default
))
299 ((:ipv4
:stream
:passive
)
300 (%make-socket
/internet-stream-passive args
:ipv4
:default
))
301 ((:ipv6
:stream
:passive
)
302 (%make-socket
/internet-stream-passive args
:ipv6
:default
))
303 ((:local
:stream
:active
)
304 (%make-socket
/local-stream-active args
:local
:default
))
305 ((:local
:stream
:passive
)
306 (%make-socket
/local-stream-passive args
:local
:default
))
308 (%make-socket
/internet-datagram args
:ipv4
:default
))
310 (%make-socket
/internet-datagram args
:ipv6
:default
))
312 (%make-socket
/local-datagram args
:local
:default
))
314 (%make-socket
/internet-raw args
:ipv4 protocol
))
316 (%make-socket
/netlink-raw args
:netlink protocol
))))))
318 (define-compiler-macro make-socket
(&whole form
&environment env
&rest args
319 &key
(address-family :internet
) (type :stream
) (protocol :default
)
320 (connect :active
) (ipv6 '*ipv6
* ipv6p
) &allow-other-keys
)
321 (when (eql :file address-family
) (setf address-family
:local
))
323 ((and (constantp address-family env
) (constantp type env
) (constantp connect env
))
324 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
:netlink
)
325 "one of :INTERNET, :LOCAL(or :FILE), :IPV4, :IPV6 or :NETLINK")
326 (check-type type
(member :stream
:datagram
:raw
) "either :STREAM, :DATAGRAM or :RAW")
327 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
328 (let* ((family (if (member address-family
'(:ipv4
:ipv6
)) :internet address-family
))
329 (lower-function (make-first-level-name family type connect
))
330 (args (remove-from-plist args
:address-family
:type
:protocol
:connect
:ipv6
)))
332 (:internet
(setf address-family
'+default-inet-address-family
+))
333 (:ipv4
(setf ipv6 nil ipv6p t
)))
334 (let ((expansion `(,lower-function
(list ,@args
) ,address-family
,protocol
)))
335 (if ipv6p
`(let ((*ipv6
* ,ipv6
)) ,expansion
) expansion
))))
338 (defmacro with-open-socket
((var &rest args
) &body body
)
339 "Bind VAR to a socket created by passing ARGS to MAKE-SOCKET and execute BODY as implicit PROGN.
340 The socket is automatically closed upon exit."
341 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
343 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
344 "Bind VAR to a socket created by passing PASSIVE-SOCKET and ARGS to ACCEPT-CONNECTION and execute BODY as implicit PROGN.
345 The socket is automatically closed upon exit."
346 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
349 ;;; MAKE-SOCKET-FROM-FD
351 ;;; FIXME: must come up with a way to find out
352 ;;; whether a socket is active or passive
353 (defmethod make-socket-from-fd ((fd integer
) &key
(dup t
) (connect :active
) (external-format :default
)
354 input-buffer-size output-buffer-size
)
355 (flet ((%get-address-family
(fd)
356 (with-sockaddr-storage-and-socklen (ss size
)
357 (%getsockname fd ss size
)
358 (eswitch ((foreign-slot-value ss
'sockaddr-storage
'family
) :test
#'=)
363 (af-netlink :netlink
))))
365 (eswitch ((get-socket-option-int fd sol-socket so-type
) :test
#'=)
366 (sock-stream :stream
)
367 (sock-dgram :datagram
)
369 (create-socket (%get-address-family fd
)
375 :external-format external-format
376 :input-buffer-size input-buffer-size
377 :output-buffer-size output-buffer-size
)))
382 (defmethod make-socket-pair (&key
(type :stream
) (protocol :default
) (external-format :default
)
383 input-buffer-size output-buffer-size
)
384 (flet ((%make-socket-pair
(fd)
385 (make-socket-from-fd fd
:dup nil
386 :external-format external-format
387 :input-buffer-size input-buffer-size
388 :output-buffer-size output-buffer-size
)))
389 (multiple-value-bind (fd1 fd2
)
390 (multiple-value-call #'%socketpair
391 (translate-make-socket-keywords-to-constants :local type protocol
))
392 (values (%make-socket-pair fd1
)
393 (%make-socket-pair fd2
)))))
396 ;;; SEND/RECEIVE-FILE-DESCRIPTOR
398 (defun call-with-buffers-for-fd-passing (fn)
399 (with-foreign-object (msg 'msghdr
)
400 (isys:bzero msg
(isys:sizeof
'msghdr
))
401 (with-foreign-pointer (buffer #.
(isys:cmsg.space
(isys:sizeof
:int
))
403 (isys:bzero buffer buffer-size
)
404 (with-foreign-slots ((control controllen
) msg msghdr
)
406 controllen buffer-size
)
407 (let ((cmsg (isys:cmsg.firsthdr msg
)))
408 (with-foreign-slots ((len level type
) cmsg cmsghdr
)
409 (setf len
(isys:cmsg.len
(isys:sizeof
:int
))
412 (funcall fn msg cmsg
)))))))
414 (defmacro with-buffers-for-fd-passing
((msg-var cmsg-var
) &body body
)
415 `(call-with-buffers-for-fd-passing (lambda (,msg-var
,cmsg-var
) ,@body
)))
417 (defmethod send-file-descriptor ((socket local-socket
) file-descriptor
)
418 (with-buffers-for-fd-passing (msg cmsg
)
419 (let ((data (isys:cmsg.data cmsg
)))
420 (setf (mem-aref data
:int
) file-descriptor
)
421 (%sendmsg
(fd-of socket
) msg
0)
424 (defmethod receive-file-descriptor ((socket local-socket
))
425 (with-buffers-for-fd-passing (msg cmsg
)
426 (let ((data (isys:cmsg.data cmsg
)))
427 (%recvmsg
(fd-of socket
) msg
0)
428 (mem-aref data
:int
))))