1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Various socket methods.
6 (in-package :iolib.sockets
)
8 ;;;-------------------------------------------------------------------------
9 ;;; Shared Initialization
10 ;;;-------------------------------------------------------------------------
12 (defun translate-make-socket-keywords-to-constants (address-family type protocol
)
13 (let ((sf (ecase address-family
18 (:netlink af-netlink
)))
21 (:datagram sock-dgram
)
23 (sp (etypecase protocol
28 (defmethod socket-os-fd ((socket socket
))
31 (defmethod shared-initialize :after
32 ((socket socket
) slot-names
33 &key file-descriptor
(dup t
) address-family type protocol
)
34 (declare (ignore slot-names
))
35 (with-accessors ((fd fd-of
) (fam socket-address-family
) (proto socket-protocol
))
37 (setf fd
(or (and file-descriptor
(if dup
38 (isys:dup file-descriptor
)
40 (multiple-value-call #'%socket
41 (translate-make-socket-keywords-to-constants
42 address-family type protocol
))))
43 (setf fam address-family
46 (defmethod (setf external-format-of
) (external-format (socket passive-socket
))
47 (setf (slot-value socket
'external-format
)
48 (babel:ensure-external-format
(or external-format
:default
))))
50 (defmethod shared-initialize :after
((socket passive-socket
) slot-names
52 input-buffer-size output-buffer-size
)
53 ;; Makes CREATE-SOCKET simpler
54 (declare (ignore slot-names input-buffer-size output-buffer-size
))
55 (setf (external-format-of socket
) (or external-format
:default
)))
58 ;;;-------------------------------------------------------------------------
60 ;;;-------------------------------------------------------------------------
62 (defmethod socket-type ((socket stream-socket
))
65 (defmethod socket-type ((socket datagram-socket
))
68 (defun socket-ipv6-p (socket)
69 "Return T if SOCKET is an AF_INET6 socket."
70 (eql :ipv6
(socket-address-family socket
)))
72 (defun ipv6-socket-p (&rest args
)
73 (apply #'socket-ipv6-p args
))
75 (defobsolete ipv6-socket-p socket-ipv6-p
)
78 ;;;-------------------------------------------------------------------------
80 ;;;-------------------------------------------------------------------------
82 (defun sock-fam (socket)
83 (ecase (socket-address-family socket
)
87 (defmethod print-object ((socket socket-stream-internet-active
) stream
)
88 (print-unreadable-object (socket stream
:identity t
)
89 (format stream
"active ~A stream socket" (sock-fam socket
))
90 (if (socket-connected-p socket
)
91 (multiple-value-bind (host port
) (remote-name socket
)
92 (format stream
" connected to ~A/~A"
93 (address-to-string host
) port
))
94 (format stream
", ~:[closed~;unconnected~]" (fd-of socket
)))))
96 (defmethod print-object ((socket socket-stream-internet-passive
) stream
)
97 (print-unreadable-object (socket stream
:identity t
)
98 (format stream
"passive ~A stream socket" (sock-fam socket
))
99 (if (socket-bound-p socket
)
100 (multiple-value-bind (host port
) (local-name socket
)
101 (format stream
" ~:[bound to~;waiting @~] ~A/~A"
102 (socket-listening-p socket
)
103 (address-to-string host
) port
))
104 (format stream
", ~:[closed~;unbound~]" (fd-of socket
)))))
106 (defmethod print-object ((socket socket-stream-local-active
) stream
)
107 (print-unreadable-object (socket stream
:identity t
)
108 (format stream
"active local stream socket")
109 (if (socket-connected-p socket
)
110 (format stream
" connected to ~S"
111 (address-to-string (remote-filename socket
)))
112 (format stream
", ~:[closed~;unconnected~]" (fd-of socket
)))))
114 (defmethod print-object ((socket socket-stream-local-passive
) stream
)
115 (print-unreadable-object (socket stream
:identity t
)
116 (format stream
"passive local stream socket")
117 (if (socket-bound-p socket
)
118 (format stream
" ~:[bound to~;waiting @~] ~A"
119 (socket-listening-p socket
)
120 (address-to-string (local-filename socket
)))
121 (format stream
", ~:[closed~;unbound~]" (fd-of socket
)))))
123 (defmethod print-object ((socket socket-datagram-local
) stream
)
124 (print-unreadable-object (socket stream
:identity t
)
125 (format stream
"local datagram socket")
126 (if (socket-connected-p socket
)
127 (format stream
" connected to ~S"
128 (address-to-string (remote-filename socket
)))
130 (format stream
" waiting @ ~S" (address-to-string (local-filename socket
)))
131 (format stream
", closed" )))))
133 (defmethod print-object ((socket socket-datagram-internet
) stream
)
134 (print-unreadable-object (socket stream
:identity t
)
135 (format stream
"~A datagram socket" (sock-fam socket
))
136 (if (socket-connected-p socket
)
137 (multiple-value-bind (host port
) (remote-name socket
)
138 (format stream
" connected to ~A/~A"
139 (address-to-string host
) port
))
141 (multiple-value-bind (host port
) (local-name socket
)
142 (format stream
" waiting @ ~A/~A"
143 (address-to-string host
) port
))
144 (format stream
", closed" )))))
147 (defmethod print-object ((socket socket-raw-netlink
) stream
)
148 (print-unreadable-object (socket stream
:identity t
)
149 (format stream
"netlink socket")
150 (if (socket-bound-p socket
)
151 (multiple-value-bind (address port
)
153 (format stream
" bound to ~A@~A"
154 port
(address-to-string address
)))
155 (format stream
", ~:[closed~;unbound~]" (fd-of socket
)))))
158 ;;;-------------------------------------------------------------------------
160 ;;;-------------------------------------------------------------------------
162 (defmethod close :before
((socket socket
) &key abort
)
163 (declare (ignore abort
))
164 (setf (slot-value socket
'bound
) nil
))
166 (defmethod close ((socket socket
) &key abort
)
167 (declare (ignore abort
))
168 (when (next-method-p)
170 (socket-open-p socket
))
172 (defmethod close :before
((socket passive-socket
) &key abort
)
173 (declare (ignore abort
))
174 (setf (slot-value socket
'listening
) nil
))
176 (defmethod socket-open-p ((socket socket
))
177 (if (null (fd-of socket
))
179 (with-sockaddr-storage-and-socklen (ss size
)
181 (%getsockname
(fd-of socket
) ss size
)
183 (socket-connection-reset-error () nil
)
184 (:no-error
(_) (declare (ignore _
)) t
)))))
187 ;;;-------------------------------------------------------------------------
189 ;;;-------------------------------------------------------------------------
191 (defun %local-name
(socket)
192 (with-sockaddr-storage-and-socklen (ss size
)
193 (%getsockname
(fd-of socket
) ss size
)
194 (sockaddr-storage->sockaddr ss
)))
196 (defmethod local-name ((socket socket
))
197 (%local-name socket
))
199 (defmethod local-host ((socket internet-socket
))
200 (nth-value 0 (%local-name socket
)))
202 (defmethod local-port ((socket internet-socket
))
203 (nth-value 1 (%local-name socket
)))
206 (defmethod local-port ((socket netlink-socket
))
207 (nth-value 1 (%local-name socket
)))
209 (defmethod local-filename ((socket local-socket
))
210 (%local-name socket
))
213 ;;;-------------------------------------------------------------------------
215 ;;;-------------------------------------------------------------------------
217 (defun %remote-name
(socket)
218 (with-sockaddr-storage-and-socklen (ss size
)
219 (%getpeername
(fd-of socket
) ss size
)
220 (sockaddr-storage->sockaddr ss
)))
222 (defmethod remote-name ((socket socket
))
223 (%remote-name socket
))
225 (defmethod remote-host ((socket internet-socket
))
226 (nth-value 0 (%remote-name socket
)))
228 (defmethod remote-port ((socket internet-socket
))
229 (nth-value 1 (%remote-name socket
)))
231 (defmethod remote-filename ((socket local-socket
))
232 (%remote-name socket
))
235 ;;;-------------------------------------------------------------------------
237 ;;;-------------------------------------------------------------------------
239 (defmethod bind-address :before
((socket internet-socket
) address
240 &key
(reuse-address t
))
241 (declare (ignore address
))
243 (setf (socket-option socket
:reuse-address
) t
)))
245 (defun bind-ipv4-address (fd address port
)
246 (with-sockaddr-in (sin address port
)
247 (%bind fd sin
(isys:sizeof
'sockaddr-in
))))
249 (defun bind-ipv6-address (fd address port
)
250 (with-sockaddr-in6 (sin6 address port
)
251 (%bind fd sin6
(isys:sizeof
'sockaddr-in6
))))
253 (defmethod bind-address ((socket internet-socket
) (address ipv4-address
)
255 (let ((port (ensure-numerical-service port
)))
256 (if (socket-ipv6-p socket
)
257 (bind-ipv6-address (fd-of socket
)
258 (map-ipv4-vector-to-ipv6 (address-name address
))
260 (bind-ipv4-address (fd-of socket
) (address-name address
) port
)))
263 (defmethod bind-address ((socket internet-socket
) (address ipv6-address
)
265 (bind-ipv6-address (fd-of socket
)
266 (address-name address
)
267 (ensure-numerical-service port
))
270 (defmethod bind-address ((socket local-socket
) (address local-address
) &key
)
271 (with-sockaddr-un (sun (address-name address
) (abstract-address-p address
))
272 (%bind
(fd-of socket
) sun
(actual-size-of-sockaddr-un sun
)))
276 (defmethod bind-address ((socket netlink-socket
) (address netlink-address
)
278 (with-sockaddr-nl (snl (netlink-address-multicast-groups address
) port
)
279 (%bind
(fd-of socket
) snl
(isys:sizeof
'sockaddr-nl
)))
282 (defmethod bind-address :after
((socket socket
) (address address
) &key
)
283 (setf (slot-value socket
'bound
) t
))
286 ;;;-------------------------------------------------------------------------
288 ;;;-------------------------------------------------------------------------
290 (defmethod listen-on ((socket socket
) &key backlog
)
291 (unless backlog
(setf backlog
(min *default-backlog-size
*
292 +max-backlog-size
+)))
293 (check-type backlog unsigned-byte
"a non-negative integer")
294 (%listen
(fd-of socket
) backlog
)
295 (setf (slot-value socket
'listening
) t
)
299 ;;;-------------------------------------------------------------------------
301 ;;;-------------------------------------------------------------------------
303 (defmethod accept-connection ((socket passive-socket
) &key external-format
304 input-buffer-size output-buffer-size
(wait t
))
305 (check-type wait timeout-designator
)
306 (flet ((make-client-socket (fd)
307 (make-instance (active-class socket
)
308 :address-family
(socket-address-family socket
)
309 :file-descriptor fd
:dup nil
310 :external-format
(or external-format
311 (external-format-of socket
))
312 :input-buffer-size input-buffer-size
313 :output-buffer-size output-buffer-size
)))
314 (ignore-some-conditions (isys:ewouldblock iomux
:poll-timeout
)
315 (iomux:wait-until-fd-ready
(fd-of socket
) :input
(wait->timeout wait
) t
)
316 (with-sockaddr-storage-and-socklen (ss size
)
317 (multiple-value-call #'values
318 (make-client-socket (%accept
(fd-of socket
) ss size
))
319 (sockaddr-storage->sockaddr ss
))))))
322 ;;;-------------------------------------------------------------------------
324 ;;;-------------------------------------------------------------------------
326 (defun ipv4-connect (fd address port
)
327 (with-sockaddr-in (sin address port
)
328 (%connect fd sin
(isys:sizeof
'sockaddr-in
))))
330 (defun ipv6-connect (fd address port
)
331 (with-sockaddr-in6 (sin6 address port
)
332 (%connect fd sin6
(isys:sizeof
'sockaddr-in6
))))
334 (defun call-with-socket-to-wait-connect (socket thunk wait
)
335 (check-type wait timeout-designator
)
336 (let ((timeout (wait->timeout wait
)))
339 (when (or (null timeout
)
342 (iomux:wait-until-fd-ready
(fd-of socket
) :output timeout t
)
344 (let ((errcode (socket-option socket
:error
)))
346 (bug "Polling socket signalled an error but SO_ERROR is 0")
347 (signal-socket-error errcode
"connect" (fd-of socket
)))))))))
348 (ignore-some-conditions (iomux:poll-timeout
)
351 ((or isys
:ewouldblock
355 (defmacro with-socket-to-wait-connect
((socket wait
) &body body
)
356 `(call-with-socket-to-wait-connect ,socket
(lambda () ,@body
) ,wait
))
358 (defmethod connect ((socket internet-socket
) (address inet-address
)
359 &key
(port 0) (wait t
))
360 (let ((name (address-name address
))
361 (port (ensure-numerical-service port
)))
362 (with-socket-to-wait-connect (socket wait
)
364 ((socket-ipv6-p socket
)
365 (when (ipv4-address-p address
)
366 (setf name
(map-ipv4-vector-to-ipv6 name
)))
367 (ipv6-connect (fd-of socket
) name port
))
368 (t (ipv4-connect (fd-of socket
) name port
)))))
371 (defmethod connect ((socket local-socket
) (address local-address
) &key
(wait t
))
372 (with-socket-to-wait-connect (socket wait
)
373 (with-sockaddr-un (sun (address-name address
) (abstract-address-p address
))
374 (%connect
(fd-of socket
) sun
(actual-size-of-sockaddr-un sun
))))
377 (defmethod socket-connected-p ((socket socket
))
379 (with-sockaddr-storage-and-socklen (ss size
)
381 (%getpeername
(fd-of socket
) ss size
)
382 ((or isys
:enotconn isys
:einval
) () nil
)
383 (:no-error
(_) (declare (ignore _
)) t
)))
387 ;;;-------------------------------------------------------------------------
389 ;;;-------------------------------------------------------------------------
391 (defmethod disconnect ((socket datagram-socket
))
392 (with-foreign-object (sin 'sockaddr-in
)
393 (isys:bzero sin
(isys:sizeof
'sockaddr-in
))
394 (setf (foreign-slot-value sin
'sockaddr-in
'addr
) af-unspec
)
395 (%connect
(fd-of socket
) sin
(isys:sizeof
'sockaddr-in
))
399 ;;;-------------------------------------------------------------------------
401 ;;;-------------------------------------------------------------------------
403 (defmethod shutdown ((socket socket
) &key read write
)
404 (assert (or read write
) (read write
)
405 "You must select at least one direction to shut down.")
406 (%shutdown
(fd-of socket
)
407 (multiple-value-case ((read write
))
414 ;;;-------------------------------------------------------------------------
415 ;;; Socket flag definition
416 ;;;-------------------------------------------------------------------------
418 (defmacro define-socket-flag
(place name value platform
)
419 (let ((val (cond ((or (not platform
)
420 (featurep platform
)) value
)
421 ((not (featurep platform
)) 0))))
422 `(pushnew (cons ,name
,val
) ,place
)))
424 (defmacro define-socket-flags
(place &body definitions
)
426 (destructuring-bind (name value
&optional platform
) form
427 `(define-socket-flag ,place
,name
,value
,platform
))))
429 ,@(mapcar #'dflag definitions
))))
432 ;;;-------------------------------------------------------------------------
434 ;;;-------------------------------------------------------------------------
436 (defvar *sendto-flags
* ())
438 (define-socket-flags *sendto-flags
*
439 (:dont-route msg-dontroute
)
440 (:dont-wait msg-dontwait
(:not
:windows
))
441 (:out-of-band msg-oob
)
442 (:more msg-more
:linux
)
443 (:confirm msg-confirm
:linux
))
445 (defun %%send-to
(fd ss got-peer buff-sap start length flags
)
446 (incf-pointer buff-sap start
)
450 (%sendto fd buff-sap length flags
451 (if got-peer ss
(null-pointer))
452 (if got-peer
(sockaddr-size ss
) 0)))
453 (ignore-syscall-error ()
454 :report
"Ignore this socket condition"
455 :test isys
:syscall-error-p
457 (retry-syscall (&optional
(timeout 15.0d0
))
458 :report
"Try to send data again"
459 :test isys
:syscall-error-p
460 (when (plusp timeout
)
461 (iomux:wait-until-fd-ready fd
:output timeout nil
))))))
463 (defun %send-to
(fd ss got-peer buffer start end flags
)
466 (check-bounds buffer start end
)
467 (with-pointer-to-vector-data (buff-sap buffer
)
468 (%%send-to fd ss got-peer buff-sap start
(- end start
) flags
)))
469 ((or ub8-vector
(vector t
))
470 (check-bounds buffer start end
)
471 (with-pointer-to-vector-data (buff-sap (coerce buffer
'ub8-sarray
))
472 (%%send-to fd ss got-peer buff-sap start
(- end start
) flags
)))
474 (check-type start unsigned-byte
)
475 (check-type end unsigned-byte
)
476 (%%send-to fd ss got-peer buffer start
(- end start
) flags
))))
478 (defmethod send-to ((socket internet-socket
) buffer
&rest args
479 &key
(start 0) end remote-host
(remote-port 0) flags
(ipv6 *ipv6
*))
481 (with-sockaddr-storage (ss)
483 (sockaddr->sockaddr-storage ss
(ensure-hostname remote-host
)
484 (ensure-numerical-service remote-port
)))
485 (%send-to
(fd-of socket
) ss
(if remote-host t
) buffer start end
486 (or flags
(compute-flags *sendto-flags
* args
))))))
488 (defmethod send-to ((socket local-socket
) buffer
&rest args
489 &key
(start 0) end remote-filename flags
)
490 (with-sockaddr-storage (ss)
491 (when remote-filename
492 (sockaddr->sockaddr-storage ss
(ensure-address remote-filename
:family
:local
) 0))
493 (%send-to
(fd-of socket
) ss
(if remote-filename t
) buffer start end
494 (or flags
(compute-flags *sendto-flags
* args
)))))
496 (define-compiler-macro send-to
(&whole form
&environment env socket buffer
&rest args
497 &key
(start 0) end
(remote-host nil host-p
) (remote-port 0 port-p
)
498 (remote-filename nil file-p
) flags
(ipv6 '*ipv6
* ipv6-p
) &allow-other-keys
)
499 (let ((flags-val (compute-flags *sendto-flags
* args env
)))
501 ((and (not flags
) flags-val
)
503 `(send-to ,socket
,buffer
:start
,start
:end
,end
:flags
,flags-val
)
504 (when host-p
`(:remote-host
,remote-host
))
505 (when port-p
`(:remote-port
,remote-port
))
506 (when ipv6-p
`(:ipv6
,ipv6
))
507 (when file-p
`(:remote-filename
,remote-filename
))))
512 ;;;-------------------------------------------------------------------------
514 ;;;-------------------------------------------------------------------------
516 (defvar *recvfrom-flags
* ())
518 (define-socket-flags *recvfrom-flags
*
519 (:out-of-band msg-oob
)
521 (:wait-all msg-waitall
(:not
:windows
))
522 (:dont-wait msg-dontwait
(:not
:windows
)))
524 (defun %%receive-from
(fd ss size buffer start length flags
)
525 (with-pointer-to-vector-data (buff-sap buffer
)
526 (incf-pointer buff-sap start
)
529 (return* (%recvfrom fd buff-sap length flags ss size
))
530 (ignore-syscall-error ()
531 :report
"Ignore this socket condition"
532 :test isys
:syscall-error-p
534 (retry-syscall (&optional
(timeout 15.0d0
))
535 :report
"Try to receive data again"
536 :test isys
:syscall-error-p
537 (when (plusp timeout
)
538 (iomux:wait-until-fd-ready fd
:input timeout nil
)))))))
540 (defun %receive-from
(fd ss size buffer start end flags
)
541 (check-bounds buffer start end
)
542 (flet ((%do-recvfrom
(buff start length
)
543 (%%receive-from fd ss size buff start length flags
)))
547 (setf nbytes
(%do-recvfrom buffer start
(- end start
))))
548 ((or ub8-vector
(vector t
))
549 (let ((tmpbuff (make-array (- end start
) :element-type
'ub8
)))
550 (setf nbytes
(%do-recvfrom tmpbuff
0 (- end start
)))
551 (replace buffer tmpbuff
:start1 start
:end1 end
:start2
0 :end2 nbytes
))))
554 (defmethod receive-from :around
((socket socket
) &rest args
555 &key buffer size
(start 0) end flags
&allow-other-keys
)
556 (let ((flags-val (or flags
(compute-flags *recvfrom-flags
* args
))))
559 (call-next-method socket
:buffer buffer
:start start
:end end
:flags flags-val
))
561 (check-type size unsigned-byte
"a non-negative integer")
562 (call-next-method socket
:buffer
(make-array size
:element-type
'ub8
)
563 :start
0 :end size
:flags flags-val
)))))
565 (defmethod receive-from ((socket stream-socket
) &key buffer start end flags
)
566 (with-sockaddr-storage-and-socklen (ss size
)
567 (let ((nbytes (%receive-from
(fd-of socket
) ss size buffer start end flags
)))
568 (values buffer nbytes
))))
570 (defmethod receive-from ((socket datagram-socket
) &key buffer start end flags
)
571 (with-sockaddr-storage-and-socklen (ss size
)
572 (let ((nbytes (%receive-from
(fd-of socket
) ss size buffer start end flags
)))
573 (multiple-value-call #'values buffer nbytes
574 (sockaddr-storage->sockaddr ss
)))))
576 (define-compiler-macro receive-from
(&whole form
&environment env socket
&rest args
577 &key buffer size
(start 0) end flags
&allow-other-keys
)
578 (let ((flags-val (compute-flags *recvfrom-flags
* args env
)))
580 ((and (not flags
) flags-val
)
581 `(receive-from ,socket
:buffer
,buffer
:start
,start
:end
,end
582 :size
,size
:flags
,flags-val
))