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', execute `BODY' as implicit PROGN and return `VAR'.
29 If a non-local exit occurs during the execution of `BODY' call CLOSE with :ABORT T on `VAR'."
30 (with-gensyms (errorp)
31 `(let ((,var
,value
) (,errorp t
))
33 (multiple-value-prog1 (locally ,@body
,var
) (setf ,errorp nil
))
34 (when (and ,var
,errorp
) (close ,var
:abort t
))))))
36 (defmacro %create-internet-socket
(family &rest args
)
38 (:ipv4
(create-socket :ipv4
,@args
))
39 (:ipv6
(create-socket :ipv6
,@args
))))
41 (defmacro with-guard-against-non-list-args-and-destructuring-bind-errors
42 (form args
&body body
)
44 (handler-case (progn ,@body
)
45 (error (err) `(error ,err
)))
48 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
49 (defun make-first-level-name (family type connect
)
50 (format-symbol :net.sockets
"%~A-~A-~A-~A-~A" :make family type connect
:socket
)))
52 (defmacro define-socket-creator
((socket-family socket-type socket-connect
)
53 (family ef key
&rest args
) &body body
)
54 (assert (eql '&key key
))
55 (flet ((maybe-quote-default-value (arg)
56 (cond ((symbolp arg
) arg
)
57 ((consp arg
) (list (first arg
) `(quote ,(second arg
))))))
59 (cond ((symbolp arg
) arg
)
60 ((consp arg
) (first arg
))))
62 `(list (quote ,(car form
)) ,@(cdr form
))))
63 (let* ((arg-names (mapcar #'arg-name args
))
64 (first-level-function (make-first-level-name socket-family socket-type socket-connect
))
65 (second-level-function (format-symbol t
"%~A" first-level-function
))
66 (first-level-body `(,second-level-function family ef
,@arg-names
)))
68 (declaim (inline ,second-level-function
))
69 (defun ,second-level-function
(,family
,ef
,@arg-names
) ,@body
)
70 (defun ,first-level-function
(arguments family ef
)
71 (destructuring-bind (&key
,@args
) arguments
,first-level-body
))
72 (define-compiler-macro ,first-level-function
(&whole form arguments family ef
)
73 (with-guard-against-non-list-args-and-destructuring-bind-errors
75 ;; Must quote default values in order for them not to be evaluated
76 ;; in the compilation environment
77 (destructuring-bind (&key
,@(mapcar #'maybe-quote-default-value args
))
79 ,(quotify first-level-body
))))))))
81 ;;; Internet Stream Active Socket creation
83 (defun %%init-internet-stream-active-socket
(socket keepalive nodelay reuse-address
84 local-host local-port remote-host remote-port
)
85 (let ((local-port (ensure-numerical-service local-port
))
86 (remote-port (ensure-numerical-service remote-port
)))
87 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
88 (when keepalive
(setf (socket-option socket
:keep-alive
) t
))
89 (when nodelay
(setf (socket-option socket
:tcp-nodelay
) t
))
91 (bind-address socket
(ensure-hostname local-host
)
93 :reuse-address reuse-address
))
94 (when (plusp remote-port
)
95 (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
))))
122 (define-socket-creator (:internet
:stream
:passive
)
123 (family ef
&key interface
(reuse-address t
)
124 (local-host +any-host
+) (local-port 0)
125 (backlog *default-backlog-size
*))
126 (with-close-on-error (socket (%create-internet-socket family
:stream
:passive ef
))
127 (%%init-internet-stream-passive-socket socket interface reuse-address
128 local-host local-port backlog
)))
130 ;;; Local Stream Active Socket creation
132 (defun %%init-local-stream-active-socket
(socket local-filename remote-filename
)
133 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
135 (bind-address socket
(ensure-address local-filename
:family
:local
)))
136 (when remote-filename
137 (connect socket
(ensure-address remote-filename
:family
:local
))))
139 (define-socket-creator (:local
:stream
:active
)
140 (family ef
&key local-filename remote-filename
141 input-buffer-size output-buffer-size
)
142 (declare (ignore family
))
143 (with-close-on-error (socket (create-socket :local
:stream
:active ef
144 :input-buffer-size input-buffer-size
145 :output-buffer-size output-buffer-size
))
146 (%%init-local-stream-active-socket socket local-filename remote-filename
)))
148 ;;; Local Stream Passive Socket creation
150 (defun %%init-local-stream-passive-socket
(socket local-filename reuse-address backlog
)
152 (bind-address socket
(ensure-address local-filename
:family
:local
)
153 :reuse-address reuse-address
)
154 (listen-on socket
:backlog backlog
)))
156 (define-socket-creator (:local
:stream
:passive
)
157 (family ef
&key local-filename
(reuse-address t
)
158 (backlog *default-backlog-size
*))
159 (declare (ignore family
))
160 (with-close-on-error (socket (create-socket :local
:stream
:passive ef
))
161 (%%init-local-stream-passive-socket socket local-filename reuse-address backlog
)))
163 ;;; Internet Datagram Socket creation
165 (defun %%init-internet-datagram-active-socket
(socket broadcast interface reuse-address
166 local-host local-port remote-host remote-port
)
167 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
168 (let ((local-port (ensure-numerical-service local-port
))
169 (remote-port (ensure-numerical-service remote-port
)))
170 (when broadcast
(setf (socket-option socket
:broadcast
) t
))
172 (bind-address socket
(ensure-hostname local-host
)
174 :reuse-address reuse-address
)
176 (setf (socket-option socket
:bind-to-device
) interface
)))
177 (when (plusp remote-port
)
178 (connect socket
(ensure-hostname remote-host
)
179 :port remote-port
))))
181 (define-socket-creator (:internet
:datagram
:active
)
182 (family ef
&key broadcast interface
(reuse-address t
)
183 local-host
(local-port 0)
184 (remote-host +any-host
+) (remote-port 0))
185 (with-close-on-error (socket (%create-internet-socket family
:datagram
:active ef
))
186 (%%init-internet-datagram-active-socket socket broadcast interface reuse-address
187 local-host local-port remote-host remote-port
)))
189 ;;; Local Datagram Socket creation
191 (defun %%init-local-datagram-active-socket
(socket local-filename remote-filename
)
192 (setf (socket-option socket
:no-sigpipe
:if-does-not-exist nil
) t
)
194 (bind-address socket
(ensure-address local-filename
:family
:local
)))
195 (when remote-filename
196 (connect socket
(ensure-address remote-filename
:family
:local
))))
198 (define-socket-creator (:local
:datagram
:active
)
199 (family ef
&key local-filename remote-filename
)
200 (declare (ignore family
))
201 (with-close-on-error (socket (create-socket :local
:datagram
:active ef
))
202 (%%init-local-datagram-active-socket socket local-filename remote-filename
)))
206 (defun make-socket (&rest args
&key
(address-family :internet
) (type :stream
)
207 (connect :active
) (ipv6 *ipv6
*)
208 (external-format :default
) &allow-other-keys
)
209 "Creates a socket instance of the appropriate subclass of SOCKET."
210 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
211 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
212 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
213 (let ((args (remove-from-plist args
:address-family
:type
:connect
:external-format
:ipv6
)))
214 (when (eq :ipv4 address-family
) (setf ipv6 nil
))
216 (when (eq :internet address-family
) (setf address-family
+default-inet-address-family
+))
217 (multiple-value-case ((address-family type connect
))
218 (((:ipv4
:ipv6
) :stream
:active
)
219 (%make-internet-stream-active-socket args address-family external-format
))
220 (((:ipv4
:ipv6
) :stream
:passive
)
221 (%make-internet-stream-passive-socket args address-family external-format
))
222 ((:local
:stream
:active
)
223 (%make-local-stream-active-socket args
:local external-format
))
224 ((:local
:stream
:passive
)
225 (%make-local-stream-passive-socket args
:local external-format
))
226 (((:ipv4
:ipv6
) :datagram
)
227 (%make-internet-datagram-active-socket args address-family external-format
))
229 (%make-local-datagram-active-socket args
:local external-format
))))))
231 (define-compiler-macro make-socket
(&whole form
&rest args
&key
(address-family :internet
) (type :stream
)
232 (connect :active
) (ipv6 '*ipv6
* ipv6p
)
233 (external-format :default
) &allow-other-keys
)
235 ((and (constantp address-family
) (constantp type
) (constantp connect
))
236 (check-type address-family
(member :internet
:local
:ipv4
:ipv6
) "one of :INTERNET, :LOCAL, :IPV4 or :IPV6")
237 (check-type type
(member :stream
:datagram
) "either :STREAM or :DATAGRAM")
238 (check-type connect
(member :active
:passive
) "either :ACTIVE or :PASSIVE")
239 (let* ((family (if (member address-family
'(:ipv4
:ipv6
)) :internet address-family
))
240 (lower-function (make-first-level-name family type connect
))
241 (newargs (remove-from-plist args
:address-family
:type
:connect
:external-format
:ipv6
)))
243 (:internet
(setf address-family
'+default-inet-address-family
+))
244 (:ipv4
(setf ipv6 nil ipv6p t
)))
245 (let ((expansion `(,lower-function
(list ,@newargs
) ,address-family
,external-format
)))
246 (if ipv6p
`(let ((*ipv6
* ,ipv6
)) ,expansion
) expansion
))))
249 (defmacro with-open-socket
((var &rest args
) &body body
)
250 "VAR is bound to a socket created by passing ARGS to
251 MAKE-SOCKET and BODY is executed as implicit PROGN. The socket
252 is automatically closed upon exit."
253 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
255 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
256 "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
257 ACCEPT-CONNECTION and BODY is executed as implicit PROGN. The socket
258 is automatically closed upon exit."
259 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))
261 ;;; MAKE-SOCKET-FROM-FD
263 ;;; FIXME: must come up with a way to find out
264 ;;; whether a socket is active or passive
265 (defun make-socket-from-fd (fd &key
(connect :active
) (external-format :default
)
266 input-buffer-size output-buffer-size
)
267 "Creates an socket instance of the appropriate subclass of SOCKET using `FD'.
268 The connection type of the socket must be specified(:ACTIVE or :PASSIVE).
269 The address family and type of the socket is automatically discovered using OS functions. Buffer sizes
270 for the new socket can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
271 (flet ((%get-address-family
(fd)
272 (with-sockaddr-storage-and-socklen (ss size
)
273 (%getsockname fd ss size
)
274 (eswitch ((foreign-slot-value ss
'sockaddr-storage
'family
) :test
#'=)
279 (eswitch ((get-socket-option-int fd sol-socket so-type
) :test
#'=)
280 (sock-stream :stream
)
281 (sock-dgram :datagram
))))
282 (create-socket (%get-address-family fd
)
284 connect external-format
:fd fd
285 :input-buffer-size input-buffer-size
286 :output-buffer-size output-buffer-size
)))
290 (defun make-socket-pair (&key
(type :stream
) (protocol :default
) (external-format :default
)
291 input-buffer-size output-buffer-size
)
292 "Creates a pair of sockets connected to each other.
293 The socket type can be either :STREAM or :DATAGRAM. Currently OSes can only create :LOCAL sockets this way.
294 Buffer sizes for the new sockets can also be specified using `INPUT-BUFFER-SIZE' and `OUTPUT-BUFFER-SIZE'."
295 (flet ((%make-socket-pair
(fd)
296 (make-socket-from-fd fd
:external-format external-format
297 :input-buffer-size input-buffer-size
298 :output-buffer-size output-buffer-size
)))
299 (multiple-value-bind (fd1 fd2
)
300 (multiple-value-call #'%socketpair
301 (translate-make-socket-keywords-to-constants :local type protocol
))
302 (values (%make-socket-pair fd1
)
303 (%make-socket-pair fd2
)))))
305 ;;; SEND/RECEIVE-FILE-DESCRIPTOR
307 (defun call-with-buffers-for-fd-passing (fn)
308 (with-foreign-object (msg 'msghdr
)
309 (bzero msg size-of-msghdr
)
310 (with-foreign-pointer (buffer #.
(%cmsg-space size-of-int
) buffer-size
)
311 (bzero buffer buffer-size
)
312 (with-foreign-slots ((control controllen
) msg msghdr
)
314 controllen buffer-size
)
315 (let ((cmsg (%cmsg-firsthdr msg
)))
316 (with-foreign-slots ((len level type
) cmsg cmsghdr
)
317 (setf len
(%cmsg-len size-of-int
)
320 (funcall fn msg cmsg
)))))))
322 (defmacro with-buffers-for-fd-passing
((msg-var cmsg-var
) &body body
)
323 `(call-with-buffers-for-fd-passing (lambda (,msg-var
,cmsg-var
) ,@body
)))
325 (defmethod send-file-descriptor ((socket local-socket
) file-descriptor
)
326 (with-buffers-for-fd-passing (msg cmsg
)
327 (let ((data (%cmsg-data cmsg
)))
328 (setf (mem-aref data
:int
) file-descriptor
)
329 (%sendmsg
(fd-of socket
) msg
0)
332 (defmethod receive-file-descriptor ((socket local-socket
))
333 (with-buffers-for-fd-passing (msg cmsg
)
334 (let ((data (%cmsg-data cmsg
)))
335 (%recvmsg
(fd-of socket
) msg
0)
336 (mem-aref data
:int
))))