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
)
20 ((:netlink
:raw nil
) . socket-raw-netlink
)))
22 (defun select-socket-class (address-family type connect
)
23 (or (loop :for
((sock-family sock-type sock-connect
) . class
)
25 :when
(and (eql sock-family address-family
)
27 (if sock-connect
(eql sock-connect connect
) t
))
29 (error "No socket class found !!"))))
31 (defun create-socket (family type protocol
32 &rest args
&key connect fd
&allow-other-keys
)
33 (apply #'make-instance
(select-socket-class family type connect
)
34 :address-family family
37 (remove-from-plist args
:connect
)))
39 (define-compiler-macro create-socket
(&whole form
&environment env
41 &rest args
&key connect fd
&allow-other-keys
)
43 ((and (constantp family env
) (constantp type env
) (constantp connect env
))
44 `(make-instance ',(select-socket-class family type connect
)
46 :address-family
,family
48 ,@(remove-from-plist args
:connect
)))
51 (defmacro with-close-on-error
((var value
) &body body
)
52 "Bind `VAR' to `VALUE' and execute `BODY' as implicit PROGN.
53 If a non-local exit occurs during the execution of `BODY',
54 call CLOSE with :ABORT T on `VAR'."
56 (unwind-protect-case () ,@body
57 (:abort
(close ,var
:abort t
)))))
59 (defmacro %create-internet-socket
(family &rest args
)
61 (:ipv4
(create-socket :ipv4
,@args
))
62 (:ipv6
(create-socket :ipv6
,@args
))))
64 (defmacro with-guard-against-non-list-args-and-destructuring-bind-errors
65 (form args
&body body
)
67 (handler-case (progn ,@body
)
68 (error (err) `(error ,err
)))
71 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
72 (defun make-first-level-name (family type connect
)
73 (if (eql :stream type
)
74 (format-symbol :iolib.sockets
"%~A/~A-~A-~A" :make-socket family type connect
)
75 (format-symbol :iolib.sockets
"%~A/~A-~A" :make-socket family type
))))
77 (defmacro define-socket-creator
((socket-family socket-type
&optional socket-connect
)
78 (family protocol key
&rest args
) &body body
)
79 (assert (eql '&key key
))
80 (flet ((maybe-quote-default-value (arg)
81 (cond ((symbolp arg
) arg
)
82 ((consp arg
) (list (first arg
) `(quote ,(second arg
))))))
84 (cond ((symbolp arg
) arg
)
85 ((consp arg
) (first arg
))))
87 `(list (quote ,(car form
)) ,@(cdr form
))))
88 (let* ((arg-names (mapcar #'arg-name args
))
89 (first-level-function (make-first-level-name socket-family socket-type socket-connect
))
90 (second-level-function (format-symbol t
"%~A" first-level-function
))
91 (first-level-body `(,second-level-function family protocol
,@arg-names
)))
93 (declaim (inline ,second-level-function
))
94 (defun ,second-level-function
(,family
,protocol
,@arg-names
) ,@body
)
95 (defun ,first-level-function
(arguments family protocol
)
96 (destructuring-bind (&key
,@args
) arguments
,first-level-body
))
97 (define-compiler-macro ,first-level-function
(&whole form arguments family protocol
)
98 (with-guard-against-non-list-args-and-destructuring-bind-errors
100 ;; Must quote default values in order for them not to be evaluated
101 ;; in the compilation environment
102 (destructuring-bind (&key
,@(mapcar #'maybe-quote-default-value args
))
104 ,(quotify first-level-body
))))))))
107 ;;; Internet Stream Active Socket creation
109 (defun %%init-socket
/internet-stream-active
(socket keepalive nodelay reuse-address
110 local-host local-port remote-host remote-port
)
111 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
112 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
113 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
115 (bind-address socket
(ensure-hostname local-host
)
117 :reuse-address reuse-address
))
119 (connect socket
(ensure-hostname remote-host
)
123 (define-socket-creator (:internet
:stream
:active
)
124 (family protocol
&key external-format
125 keepalive nodelay
(reuse-address t
)
126 local-host local-port remote-host remote-port
127 input-buffer-size output-buffer-size
)
128 (with-close-on-error (socket (%create-internet-socket family
:stream protocol
130 :external-format external-format
131 :input-buffer-size input-buffer-size
132 :output-buffer-size output-buffer-size
))
133 (%%init-socket
/internet-stream-active socket keepalive nodelay reuse-address
134 local-host
(or local-port
0) remote-host remote-port
)))
137 ;;; Internet Stream Passive Socket creation
139 (defun %%init-socket
/internet-stream-passive
(socket interface reuse-address
140 local-host local-port backlog
)
143 (setf (socket-option socket
:bind-to-device
) interface
))
144 (bind-address socket
(ensure-hostname local-host
)
146 :reuse-address reuse-address
)
147 (listen-on socket
:backlog backlog
))
150 (define-socket-creator (:internet
:stream
:passive
)
151 (family protocol
&key external-format
152 interface
(reuse-address t
)
153 local-host local-port backlog
)
154 (with-close-on-error (socket (%create-internet-socket family
:stream protocol
156 :external-format external-format
))
157 (%%init-socket
/internet-stream-passive socket interface reuse-address
158 local-host
(or local-port
0)
159 (or backlog
*default-backlog-size
*))))
162 ;;; Local Stream Active Socket creation
164 (defun %%init-socket
/local-stream-active
(socket local-filename remote-filename
)
165 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
167 (bind-address socket
(ensure-address local-filename
:family
:local
)))
168 (when remote-filename
169 (connect socket
(ensure-address remote-filename
:family
:local
)))
172 (define-socket-creator (:local
:stream
:active
)
173 (family protocol
&key external-format local-filename remote-filename
174 input-buffer-size output-buffer-size
)
175 (with-close-on-error (socket (create-socket family
:stream protocol
177 :external-format external-format
178 :input-buffer-size input-buffer-size
179 :output-buffer-size output-buffer-size
))
180 (%%init-socket
/local-stream-active socket local-filename remote-filename
)))
183 ;;; Local Stream Passive Socket creation
185 (defun %%init-socket
/local-stream-passive
(socket local-filename reuse-address backlog
)
187 (bind-address socket
(ensure-address local-filename
:family
:local
)
188 :reuse-address reuse-address
)
189 (listen-on socket
:backlog backlog
))
192 (define-socket-creator (:local
:stream
:passive
)
193 (family protocol
&key external-format local-filename
(reuse-address t
) backlog
)
194 (with-close-on-error (socket (create-socket family
:stream protocol
196 :external-format external-format
))
197 (%%init-socket
/local-stream-passive socket local-filename reuse-address
198 (or backlog
*default-backlog-size
*))))
201 ;;; Internet Datagram Socket creation
203 (defun %%init-socket
/internet-datagram
(socket broadcast interface reuse-address
204 local-host local-port remote-host remote-port
)
205 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
206 (when broadcast
(setf (socket-option socket
:broadcast
) t
))
208 (bind-address socket
(ensure-hostname local-host
)
210 :reuse-address reuse-address
)
212 (setf (socket-option socket
:bind-to-device
) interface
)))
214 (connect socket
(ensure-hostname remote-host
)
218 (define-socket-creator (:internet
:datagram
)
219 (family protocol
&key broadcast interface
(reuse-address t
)
220 local-host local-port remote-host remote-port
)
221 (with-close-on-error (socket (%create-internet-socket family
:datagram protocol
))
222 (%%init-socket
/internet-datagram socket broadcast interface reuse-address
223 local-host
(or local-port
0)
224 remote-host
(or remote-port
0))))
227 ;;; Local Datagram Socket creation
229 (defun %%init-socket
/local-datagram
(socket local-filename remote-filename
)
230 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
232 (bind-address socket
(ensure-address local-filename
:family
:local
)))
233 (when remote-filename
234 (connect socket
(ensure-address remote-filename
:family
:local
)))
237 (define-socket-creator (:local
:datagram
)
238 (family protocol
&key local-filename remote-filename
)
239 (with-close-on-error (socket (create-socket family
:datagram protocol
))
240 (%%init-socket
/local-datagram socket local-filename remote-filename
)))
243 ;;; Raw Socket creation
245 (defun %%init-socket
/internet-raw
(socket include-headers
)
246 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
247 (setf (socket-option socket
:ip-header-include
) include-headers
)
250 (define-socket-creator (:internet
:raw
)
251 (family protocol
&key include-headers
)
252 (with-close-on-error (socket (create-socket family
:raw protocol
))
253 (%%init-socket
/internet-raw socket include-headers
)))
256 ;;; Netlink Socket creation
258 (defun %%init-socket
/netlink-raw
(socket local-port multicast-groups
)
261 (make-instance 'netlink-address
262 :multicast-groups multicast-groups
)
266 (define-socket-creator (:netlink
:raw
)
267 (family protocol
&key
(local-port 0) (multicast-groups 0))
268 (with-close-on-error (socket (create-socket family
:raw protocol
))
269 (%%init-socket
/netlink-raw socket local-port multicast-groups
)))
274 (defmethod make-socket (&rest args
&key
(address-family :internet
) (type :stream
) (protocol :default
)
275 (connect :active
) (ipv6 *ipv6
*) &allow-other-keys
)
276 (when (eql :file address-family
) (setf address-family
:local
))
277 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
:netlink
)
278 "one of :INTERNET, :LOCAL(or :FILE), :IPV4, :IPV6 or :NETLINK")
279 (check-type type
(member :stream
:datagram
:raw
) "either :STREAM, :DATAGRAM or :RAW")
280 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
281 (let ((args (remove-from-plist args
:address-family
:type
:protocol
:connect
:ipv6
)))
282 (when (eql :ipv4 address-family
) (setf ipv6 nil
))
284 (when (eql :internet address-family
) (setf address-family
+default-inet-address-family
+))
285 (multiple-value-case ((address-family type connect
))
286 ((:ipv4
:stream
:active
)
287 (%make-socket
/internet-stream-active args
:ipv4
:default
))
288 ((:ipv6
:stream
:active
)
289 (%make-socket
/internet-stream-active args
:ipv6
:default
))
290 ((:ipv4
:stream
:passive
)
291 (%make-socket
/internet-stream-passive args
:ipv4
:default
))
292 ((:ipv6
:stream
:passive
)
293 (%make-socket
/internet-stream-passive args
:ipv6
:default
))
294 ((:local
:stream
:active
)
295 (%make-socket
/local-stream-active args
:local
:default
))
296 ((:local
:stream
:passive
)
297 (%make-socket
/local-stream-passive args
:local
:default
))
299 (%make-socket
/internet-datagram args
:ipv4
:default
))
301 (%make-socket
/internet-datagram args
:ipv6
:default
))
303 (%make-socket
/local-datagram args
:local
:default
))
305 (%make-socket
/internet-raw args
:ipv4 protocol
))
307 (%make-socket
/netlink-raw args
:netlink protocol
))))))
309 (define-compiler-macro make-socket
(&whole form
&environment env
&rest args
310 &key
(address-family :internet
) (type :stream
) (protocol :default
)
311 (connect :active
) (ipv6 '*ipv6
* ipv6p
) &allow-other-keys
)
312 (when (eql :file address-family
) (setf address-family
:local
))
314 ((and (constantp address-family env
) (constantp type env
) (constantp connect env
))
315 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
:netlink
)
316 "one of :INTERNET, :LOCAL(or :FILE), :IPV4, :IPV6 or :NETLINK")
317 (check-type type
(member :stream
:datagram
:raw
) "either :STREAM, :DATAGRAM or :RAW")
318 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
319 (let* ((family (if (member address-family
'(:ipv4
:ipv6
)) :internet address-family
))
320 (lower-function (make-first-level-name family type connect
))
321 (args (remove-from-plist args
:address-family
:type
:protocol
:connect
:ipv6
)))
323 (:internet
(setf address-family
'+default-inet-address-family
+))
324 (:ipv4
(setf ipv6 nil ipv6p t
)))
325 (let ((expansion `(,lower-function
(list ,@args
) ,address-family
,protocol
)))
326 (if ipv6p
`(let ((*ipv6
* ,ipv6
)) ,expansion
) expansion
))))
329 (defmacro with-open-socket
((var &rest args
) &body body
)
330 "Bind VAR to a socket created by passing ARGS to MAKE-SOCKET and execute BODY as implicit PROGN.
331 The socket is automatically closed upon exit."
332 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
334 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
335 "Bind VAR to a socket created by passing PASSIVE-SOCKET and ARGS to ACCEPT-CONNECTION and execute BODY as implicit PROGN.
336 The socket is automatically closed upon exit."
337 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
340 ;;; MAKE-SOCKET-FROM-FD
342 ;;; FIXME: must come up with a way to find out
343 ;;; whether a socket is active or passive
344 (defmethod make-socket-from-fd ((fd integer
) &key
(dup t
) (connect :active
) (external-format :default
)
345 input-buffer-size output-buffer-size
)
346 (flet ((%get-address-family
(fd)
347 (with-sockaddr-storage-and-socklen (ss size
)
348 (%getsockname fd ss size
)
349 (eswitch ((foreign-slot-value ss
'sockaddr-storage
'family
) :test
#'=)
353 (af-netlink :netlink
))))
355 (eswitch ((get-socket-option-int fd sol-socket so-type
) :test
#'=)
356 (sock-stream :stream
)
357 (sock-dgram :datagram
)
359 (create-socket (%get-address-family fd
)
365 :external-format external-format
366 :input-buffer-size input-buffer-size
367 :output-buffer-size output-buffer-size
)))
372 (defmethod make-socket-pair (&key
(type :stream
) (protocol :default
) (external-format :default
)
373 input-buffer-size output-buffer-size
)
374 (flet ((%make-socket-pair
(fd)
375 (make-socket-from-fd fd
:dup nil
376 :external-format external-format
377 :input-buffer-size input-buffer-size
378 :output-buffer-size output-buffer-size
)))
379 (multiple-value-bind (fd1 fd2
)
380 (multiple-value-call #'%socketpair
381 (translate-make-socket-keywords-to-constants :local type protocol
))
382 (values (%make-socket-pair fd1
)
383 (%make-socket-pair fd2
)))))
386 ;;; SEND/RECEIVE-FILE-DESCRIPTOR
388 (defun call-with-buffers-for-fd-passing (fn)
389 (with-foreign-object (msg 'msghdr
)
390 (isys:bzero msg
(isys:sizeof
'msghdr
))
391 (with-foreign-pointer (buffer #.
(isys:cmsg.space
(isys:sizeof
:int
))
393 (isys:bzero buffer buffer-size
)
394 (with-foreign-slots ((control controllen
) msg msghdr
)
396 controllen buffer-size
)
397 (let ((cmsg (isys:cmsg.firsthdr msg
)))
398 (with-foreign-slots ((len level type
) cmsg cmsghdr
)
399 (setf len
(isys:cmsg.len
(isys:sizeof
:int
))
402 (funcall fn msg cmsg
)))))))
404 (defmacro with-buffers-for-fd-passing
((msg-var cmsg-var
) &body body
)
405 `(call-with-buffers-for-fd-passing (lambda (,msg-var
,cmsg-var
) ,@body
)))
407 (defmethod send-file-descriptor ((socket local-socket
) file-descriptor
)
408 (with-buffers-for-fd-passing (msg cmsg
)
409 (let ((data (isys:cmsg.data cmsg
)))
410 (setf (mem-aref data
:int
) file-descriptor
)
411 (%sendmsg
(fd-of socket
) msg
0)
414 (defmethod receive-file-descriptor ((socket local-socket
))
415 (with-buffers-for-fd-passing (msg cmsg
)
416 (let ((data (isys:cmsg.data cmsg
)))
417 (%recvmsg
(fd-of socket
) msg
0)
418 (mem-aref data
:int
))))