1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Socket creation.
6 (in-package :net.sockets
)
8 (defvar *socket-type-map
*
9 '(((:ipv4
:stream
:active
:default
) . socket-stream-internet-active
)
10 ((:ipv6
:stream
:active
:default
) . socket-stream-internet-active
)
11 ((:ipv4
:stream
:passive
:default
) . socket-stream-internet-passive
)
12 ((:ipv6
:stream
:passive
:default
) . socket-stream-internet-passive
)
13 ((:local
:stream
:active
:default
) . socket-stream-local-active
)
14 ((:local
:stream
:passive
:default
) . socket-stream-local-passive
)
15 ((:local
:datagram
:active
:default
) . socket-datagram-local-active
)
16 ((:ipv4
:datagram
:active
:default
) . socket-datagram-internet-active
)
17 ((:ipv6
:datagram
:active
:default
) . socket-datagram-internet-active
)))
19 ;;; FIXME: should match :default to whatever protocol is the default.
20 (defun select-socket-class (address-family type connect protocol
)
21 (or (cdr (assoc (list address-family type connect protocol
) *socket-type-map
*
23 (error "No socket class found !!")))
25 (defun create-socket (family type connect external-format
&key
26 fd input-buffer-size output-buffer-size
)
27 (make-instance (select-socket-class family type connect
:default
)
28 :address-family family
:file-descriptor fd
29 :external-format external-format
30 :input-buffer-size input-buffer-size
31 :output-buffer-size output-buffer-size
))
33 (define-compiler-macro create-socket
(&whole form family type connect external-format
34 &key fd input-buffer-size output-buffer-size
)
36 ((and (constantp family
) (constantp type
) (constantp connect
))
37 `(make-instance ',(select-socket-class family type connect
:default
)
38 :address-family
,family
:file-descriptor
,fd
39 :external-format
,external-format
40 :input-buffer-size
,input-buffer-size
41 :output-buffer-size
,output-buffer-size
))
44 (defmacro with-close-on-error
((var value
) &body body
)
45 "Bind `VAR' to `VALUE' and execute `BODY' as implicit PROGN.
46 If a non-local exit occurs during the execution of `BODY',
47 call CLOSE with :ABORT T on `VAR'."
49 (unwind-protect-case () ,@body
50 (:abort
(close ,var
:abort t
)))))
52 (defmacro %create-internet-socket
(family &rest args
)
54 (:ipv4
(create-socket :ipv4
,@args
))
55 (:ipv6
(create-socket :ipv6
,@args
))))
57 (defmacro with-guard-against-non-list-args-and-destructuring-bind-errors
58 (form args
&body body
)
60 (handler-case (progn ,@body
)
61 (error (err) `(error ,err
)))
64 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
65 (defun make-first-level-name (family type connect
)
66 (format-symbol :net.sockets
"%~A-~A-~A-~A-~A" :make family type connect
:socket
)))
68 (defmacro define-socket-creator
((socket-family socket-type socket-connect
)
69 (family ef key
&rest args
) &body body
)
70 (assert (eql '&key key
))
71 (flet ((maybe-quote-default-value (arg)
72 (cond ((symbolp arg
) arg
)
73 ((consp arg
) (list (first arg
) `(quote ,(second arg
))))))
75 (cond ((symbolp arg
) arg
)
76 ((consp arg
) (first arg
))))
78 `(list (quote ,(car form
)) ,@(cdr form
))))
79 (let* ((arg-names (mapcar #'arg-name args
))
80 (first-level-function (make-first-level-name socket-family socket-type socket-connect
))
81 (second-level-function (format-symbol t
"%~A" first-level-function
))
82 (first-level-body `(,second-level-function family ef
,@arg-names
)))
84 (declaim (inline ,second-level-function
))
85 (defun ,second-level-function
(,family
,ef
,@arg-names
) ,@body
)
86 (defun ,first-level-function
(arguments family ef
)
87 (destructuring-bind (&key
,@args
) arguments
,first-level-body
))
88 (define-compiler-macro ,first-level-function
(&whole form arguments family ef
)
89 (with-guard-against-non-list-args-and-destructuring-bind-errors
91 ;; Must quote default values in order for them not to be evaluated
92 ;; in the compilation environment
93 (destructuring-bind (&key
,@(mapcar #'maybe-quote-default-value args
))
95 ,(quotify first-level-body
))))))))
97 ;;; Internet Stream Active Socket creation
99 (defun %%init-internet-stream-active-socket
(socket keepalive nodelay reuse-address
100 local-host local-port remote-host remote-port
)
101 (let ((local-port (ensure-numerical-service local-port
))
102 (remote-port (ensure-numerical-service remote-port
)))
103 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
104 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
105 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
107 (bind-address socket
(ensure-hostname local-host
)
109 :reuse-address reuse-address
))
110 (when (plusp remote-port
)
111 (connect socket
(ensure-hostname remote-host
)
115 (define-socket-creator (:internet
:stream
:active
)
116 (family ef
&key keepalive nodelay
(reuse-address t
)
117 local-host
(local-port 0)
118 (remote-host +any-host
+) (remote-port 0)
119 input-buffer-size output-buffer-size
)
120 (with-close-on-error (socket (%create-internet-socket family
:stream
:active ef
121 :input-buffer-size input-buffer-size
122 :output-buffer-size output-buffer-size
))
123 (%%init-internet-stream-active-socket socket keepalive nodelay reuse-address
124 local-host local-port remote-host remote-port
)))
126 ;;; Internet Stream Passive Socket creation
128 (defun %%init-internet-stream-passive-socket
(socket interface reuse-address
129 local-host local-port backlog
)
130 (let ((local-port (ensure-numerical-service local-port
)))
133 (setf (socket-option socket
:bind-to-device
) interface
))
134 (bind-address socket
(ensure-hostname local-host
)
136 :reuse-address reuse-address
)
137 (listen-on socket
:backlog backlog
)))
140 (define-socket-creator (:internet
:stream
:passive
)
141 (family ef
&key interface
(reuse-address t
)
142 (local-host +any-host
+) (local-port 0)
143 (backlog *default-backlog-size
*))
144 (with-close-on-error (socket (%create-internet-socket family
:stream
:passive ef
))
145 (%%init-internet-stream-passive-socket socket interface reuse-address
146 local-host local-port backlog
)))
148 ;;; Local Stream Active Socket creation
150 (defun %%init-local-stream-active-socket
(socket local-filename remote-filename
)
151 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
153 (bind-address socket
(ensure-address local-filename
:family
:local
)))
154 (when remote-filename
155 (connect socket
(ensure-address remote-filename
:family
:local
)))
158 (define-socket-creator (:local
:stream
:active
)
159 (family ef
&key local-filename remote-filename
160 input-buffer-size output-buffer-size
)
161 (declare (ignore family
))
162 (with-close-on-error (socket (create-socket :local
:stream
:active ef
163 :input-buffer-size input-buffer-size
164 :output-buffer-size output-buffer-size
))
165 (%%init-local-stream-active-socket socket local-filename remote-filename
)))
167 ;;; Local Stream Passive Socket creation
169 (defun %%init-local-stream-passive-socket
(socket local-filename reuse-address backlog
)
171 (bind-address socket
(ensure-address local-filename
:family
:local
)
172 :reuse-address reuse-address
)
173 (listen-on socket
:backlog backlog
))
176 (define-socket-creator (:local
:stream
:passive
)
177 (family ef
&key local-filename
(reuse-address t
)
178 (backlog *default-backlog-size
*))
179 (declare (ignore family
))
180 (with-close-on-error (socket (create-socket :local
:stream
:passive ef
))
181 (%%init-local-stream-passive-socket socket local-filename reuse-address backlog
)))
183 ;;; Internet Datagram Socket creation
185 (defun %%init-internet-datagram-active-socket
(socket broadcast interface reuse-address
186 local-host local-port remote-host remote-port
)
187 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
188 (let ((local-port (ensure-numerical-service local-port
))
189 (remote-port (ensure-numerical-service remote-port
)))
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
)
202 (define-socket-creator (:internet
:datagram
:active
)
203 (family ef
&key broadcast interface
(reuse-address t
)
204 local-host
(local-port 0)
205 (remote-host +any-host
+) (remote-port 0))
206 (with-close-on-error (socket (%create-internet-socket family
:datagram
:active ef
))
207 (%%init-internet-datagram-active-socket socket broadcast interface reuse-address
208 local-host local-port remote-host remote-port
)))
210 ;;; Local Datagram Socket creation
212 (defun %%init-local-datagram-active-socket
(socket local-filename remote-filename
)
213 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
215 (bind-address socket
(ensure-address local-filename
:family
:local
)))
216 (when remote-filename
217 (connect socket
(ensure-address remote-filename
:family
:local
)))
220 (define-socket-creator (:local
:datagram
:active
)
221 (family ef
&key local-filename remote-filename
)
222 (declare (ignore family
))
223 (with-close-on-error (socket (create-socket :local
:datagram
:active ef
))
224 (%%init-local-datagram-active-socket socket local-filename remote-filename
)))
228 (defun make-socket (&rest args
&key
(address-family :internet
) (type :stream
)
229 (connect :active
) (ipv6 *ipv6
*)
230 (external-format :default
) &allow-other-keys
)
231 "Creates a socket instance of the appropriate subclass of SOCKET."
232 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
233 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
234 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
235 (let ((args (remove-from-plist args
:address-family
:type
:connect
:external-format
:ipv6
)))
236 (when (eq :ipv4 address-family
) (setf ipv6 nil
))
238 (when (eq :internet address-family
) (setf address-family
+default-inet-address-family
+))
239 (multiple-value-case ((address-family type connect
))
240 (((:ipv4
:ipv6
) :stream
:active
)
241 (%make-internet-stream-active-socket args address-family external-format
))
242 (((:ipv4
:ipv6
) :stream
:passive
)
243 (%make-internet-stream-passive-socket args address-family external-format
))
244 ((:local
:stream
:active
)
245 (%make-local-stream-active-socket args
:local external-format
))
246 ((:local
:stream
:passive
)
247 (%make-local-stream-passive-socket args
:local external-format
))
248 (((:ipv4
:ipv6
) :datagram
)
249 (%make-internet-datagram-active-socket args address-family external-format
))
251 (%make-local-datagram-active-socket args
:local external-format
))))))
253 (define-compiler-macro make-socket
(&whole form
&rest args
&key
(address-family :internet
) (type :stream
)
254 (connect :active
) (ipv6 '*ipv6
* ipv6p
)
255 (external-format :default
) &allow-other-keys
)
257 ((and (constantp address-family
) (constantp type
) (constantp connect
))
258 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
259 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
260 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
261 (let* ((family (if (member address-family
'(:ipv4
:ipv6
)) :internet address-family
))
262 (lower-function (make-first-level-name family type connect
))
263 (newargs (remove-from-plist args
:address-family
:type
:connect
:external-format
:ipv6
)))
265 (:internet
(setf address-family
'+default-inet-address-family
+))
266 (:ipv4
(setf ipv6 nil ipv6p t
)))
267 (let ((expansion `(,lower-function
(list ,@newargs
) ,address-family
,external-format
)))
268 (if ipv6p
`(let ((*ipv6
* ,ipv6
)) ,expansion
) expansion
))))
271 (defmacro with-open-socket
((var &rest args
) &body body
)
272 "VAR is bound to a socket created by passing ARGS to
273 MAKE-SOCKET and BODY is executed as implicit PROGN. The socket
274 is automatically closed upon exit."
275 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
277 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
278 "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
279 ACCEPT-CONNECTION and BODY is executed as implicit PROGN. The socket
280 is automatically closed upon exit."
281 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
283 ;;; MAKE-SOCKET-FROM-FD
285 ;;; FIXME: must come up with a way to find out
286 ;;; whether a socket is active or passive
287 (defun make-socket-from-fd (fd &key
(connect :active
) (external-format :default
)
288 input-buffer-size output-buffer-size
)
289 "Creates an socket instance of the appropriate subclass of SOCKET using `FD'.
290 The connection type of the socket must be specified(:ACTIVE or :PASSIVE).
291 The address family and type of the socket is automatically discovered using OS functions. Buffer sizes
292 for the new socket can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
293 (flet ((%get-address-family
(fd)
294 (with-sockaddr-storage-and-socklen (ss size
)
295 (%getsockname fd ss size
)
296 (eswitch ((foreign-slot-value ss
'sockaddr-storage
'family
) :test
#'=)
301 (eswitch ((get-socket-option-int fd sol-socket so-type
) :test
#'=)
302 (sock-stream :stream
)
303 (sock-dgram :datagram
))))
304 (create-socket (%get-address-family fd
)
306 connect external-format
:fd fd
307 :input-buffer-size input-buffer-size
308 :output-buffer-size output-buffer-size
)))
312 (defun make-socket-pair (&key
(type :stream
) (protocol :default
) (external-format :default
)
313 input-buffer-size output-buffer-size
)
314 "Creates a pair of sockets connected to each other.
315 The socket type can be either :STREAM or :DATAGRAM. Currently OSes can only create :LOCAL sockets this way.
316 Buffer sizes for the new sockets can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
317 (flet ((%make-socket-pair
(fd)
318 (make-socket-from-fd fd
:external-format external-format
319 :input-buffer-size input-buffer-size
320 :output-buffer-size output-buffer-size
)))
321 (multiple-value-bind (fd1 fd2
)
322 (multiple-value-call #'%socketpair
323 (translate-make-socket-keywords-to-constants :local type protocol
))
324 (values (%make-socket-pair fd1
)
325 (%make-socket-pair fd2
)))))
327 ;;; SEND/RECEIVE-FILE-DESCRIPTOR
329 (defun call-with-buffers-for-fd-passing (fn)
330 (with-foreign-object (msg 'msghdr
)
331 (bzero msg size-of-msghdr
)
332 (with-foreign-pointer (buffer #.
(%cmsg-space size-of-int
) buffer-size
)
333 (bzero buffer buffer-size
)
334 (with-foreign-slots ((control controllen
) msg msghdr
)
336 controllen buffer-size
)
337 (let ((cmsg (%cmsg-firsthdr msg
)))
338 (with-foreign-slots ((len level type
) cmsg cmsghdr
)
339 (setf len
(%cmsg-len size-of-int
)
342 (funcall fn msg cmsg
)))))))
344 (defmacro with-buffers-for-fd-passing
((msg-var cmsg-var
) &body body
)
345 `(call-with-buffers-for-fd-passing (lambda (,msg-var
,cmsg-var
) ,@body
)))
347 (defmethod send-file-descriptor ((socket local-socket
) file-descriptor
)
348 (with-buffers-for-fd-passing (msg cmsg
)
349 (let ((data (%cmsg-data cmsg
)))
350 (setf (mem-aref data
:int
) file-descriptor
)
351 (%sendmsg
(fd-of socket
) msg
0)
354 (defmethod receive-file-descriptor ((socket local-socket
))
355 (with-buffers-for-fd-passing (msg cmsg
)
356 (let ((data (%cmsg-data cmsg
)))
357 (%recvmsg
(fd-of socket
) msg
0)
358 (mem-aref data
:int
))))