Rename IO-BUFFERING to STREAM-BUFFERING.
[iolib.git] / net.sockets / socket-methods.lisp
blobd58d224d885f4b64a5a3c7e1dc1ab1354d5cc320
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; --- Various socket methods.
4 ;;;
6 (in-package :net.sockets)
8 ;;;-------------------------------------------------------------------------
9 ;;; Shared Initialization
10 ;;;-------------------------------------------------------------------------
12 (defun translate-make-socket-keywords-to-constants (address-family type protocol)
13 (let ((sf (ecase address-family
14 (:ipv4 af-inet)
15 (:ipv6 af-inet6)
16 (:local af-local)))
17 (st (ecase type
18 (:stream sock-stream)
19 (:datagram sock-dgram)))
20 (sp (cond
21 ((integerp protocol) protocol)
22 ((eq :default protocol) 0)
23 (t (lookup-protocol protocol)))))
24 (values sf st sp)))
26 (defmethod socket-os-fd ((socket socket))
27 (fd-of socket))
29 (defmethod initialize-instance :after ((socket socket) &key
30 file-descriptor address-family type
31 (protocol :default))
32 (with-accessors ((fd fd-of) (fam socket-address-family) (proto socket-protocol))
33 socket
34 (setf fd (or file-descriptor
35 (multiple-value-call #'%socket
36 (translate-make-socket-keywords-to-constants
37 address-family type protocol))))
38 (setf fam address-family
39 proto protocol)))
41 (defun socket-read-fn (fd buffer nbytes)
42 (debug-only
43 (assert buffer)
44 (assert fd))
45 (%recvfrom fd buffer nbytes 0 (null-pointer) (null-pointer)))
47 (defun socket-write-fn (fd buffer nbytes)
48 (debug-only
49 (assert buffer)
50 (assert fd))
51 (%sendto fd buffer nbytes 0 (null-pointer) 0))
53 (defmethod (setf external-format-of) (external-format (socket passive-socket))
54 (setf (slot-value socket 'external-format)
55 (babel:ensure-external-format external-format)))
57 (defmethod initialize-instance :after ((socket passive-socket) &key external-format
58 input-buffer-size output-buffer-size)
59 ;; Makes CREATE-SOCKET simpler
60 (declare (ignore input-buffer-size output-buffer-size))
61 (setf (external-format-of socket) external-format))
64 ;;;-------------------------------------------------------------------------
65 ;;; Misc
66 ;;;-------------------------------------------------------------------------
68 (defmethod socket-type ((socket stream-socket))
69 :stream)
71 (defmethod socket-type ((socket datagram-socket))
72 :datagram)
74 (defun ipv6-socket-p (socket)
75 "Return T if SOCKET is an AF_INET6 socket."
76 (eq :ipv6 (socket-address-family socket)))
79 ;;;-------------------------------------------------------------------------
80 ;;; PRINT-OBJECT
81 ;;;-------------------------------------------------------------------------
83 (defun sock-fam (socket)
84 (ecase (socket-address-family socket)
85 (:ipv4 "IPv4")
86 (:ipv6 "IPv6")))
88 (defmethod print-object ((socket socket-stream-internet-active) stream)
89 (print-unreadable-object (socket stream :identity t)
90 (format stream "active ~A stream socket" (sock-fam socket))
91 (if (socket-connected-p socket)
92 (multiple-value-bind (host port) (remote-name socket)
93 (format stream " connected to ~A/~A"
94 (address-to-string host) port))
95 (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
97 (defmethod print-object ((socket socket-stream-internet-passive) stream)
98 (print-unreadable-object (socket stream :identity t)
99 (format stream "passive ~A stream socket" (sock-fam socket))
100 (if (socket-bound-p socket)
101 (multiple-value-bind (host port) (local-name socket)
102 (format stream " ~:[bound to~;waiting @~] ~A/~A"
103 (socket-listening-p socket)
104 (address-to-string host) port))
105 (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
107 (defmethod print-object ((socket socket-stream-local-active) stream)
108 (print-unreadable-object (socket stream :identity t)
109 (format stream "active local stream socket")
110 (if (socket-connected-p socket)
111 (format stream " connected to ~S"
112 (address-to-string (remote-filename socket)))
113 (format stream ", ~:[closed~;unconnected~]" (fd-of socket)))))
115 (defmethod print-object ((socket socket-stream-local-passive) stream)
116 (print-unreadable-object (socket stream :identity t)
117 (format stream "passive local stream socket")
118 (if (socket-bound-p socket)
119 (format stream " ~:[bound to~;waiting @~] ~S"
120 (socket-listening-p socket)
121 (address-to-string (local-filename socket)))
122 (format stream ", ~:[closed~;unbound~]" (fd-of socket)))))
124 (defmethod print-object ((socket socket-datagram-local-active) stream)
125 (print-unreadable-object (socket stream :identity t)
126 (format stream "local datagram socket")
127 (if (socket-connected-p socket)
128 (format stream " connected to ~S"
129 (address-to-string (remote-filename socket)))
130 (if (fd-of socket)
131 (format stream " waiting @ ~S" (address-to-string (local-filename socket)))
132 (format stream ", closed" )))))
134 (defmethod print-object ((socket socket-datagram-internet-active) stream)
135 (print-unreadable-object (socket stream :identity t)
136 (format stream "~A datagram socket" (sock-fam socket))
137 (if (socket-connected-p socket)
138 (multiple-value-bind (host port) (remote-name socket)
139 (format stream " connected to ~A/~A"
140 (address-to-string host) port))
141 (if (fd-of socket)
142 (multiple-value-bind (host port) (local-name socket)
143 (format stream " waiting @ ~A/~A"
144 (address-to-string host) port))
145 (format stream ", closed" )))))
148 ;;;-------------------------------------------------------------------------
149 ;;; CLOSE
150 ;;;-------------------------------------------------------------------------
152 (defmethod close :around ((socket socket) &key abort)
153 (declare (ignore abort))
154 (call-next-method)
155 (setf (slot-value socket 'bound) nil)
156 (values socket))
158 (defmethod close :around ((socket passive-socket) &key abort)
159 (declare (ignore abort))
160 (call-next-method)
161 (setf (slot-value socket 'listening) nil)
162 (values socket))
164 (defmethod close ((socket socket) &key abort)
165 (declare (ignore socket abort)))
167 (defmethod socket-open-p ((socket socket))
168 (when (fd-of socket)
169 (with-sockaddr-storage-and-socklen (ss size)
170 (handler-case
171 (%getsockname (fd-of socket) ss size)
172 (nix:ebadf () nil)
173 (socket-connection-reset-error () nil)
174 (:no-error (_) (declare (ignore _)) t)))))
177 ;;;-------------------------------------------------------------------------
178 ;;; GETSOCKNAME
179 ;;;-------------------------------------------------------------------------
181 (defun %local-name (socket)
182 (with-sockaddr-storage-and-socklen (ss size)
183 (%getsockname (fd-of socket) ss size)
184 (sockaddr-storage->sockaddr ss)))
186 (defmethod local-name ((socket socket))
187 (%local-name socket))
189 (defmethod local-host ((socket internet-socket))
190 (nth-value 0 (%local-name socket)))
192 (defmethod local-port ((socket internet-socket))
193 (nth-value 1 (%local-name socket)))
195 (defmethod local-filename ((socket local-socket))
196 (%local-name socket))
199 ;;;-------------------------------------------------------------------------
200 ;;; GETPEERNAME
201 ;;;-------------------------------------------------------------------------
203 (defun %remote-name (socket)
204 (with-sockaddr-storage-and-socklen (ss size)
205 (%getpeername (fd-of socket) ss size)
206 (sockaddr-storage->sockaddr ss)))
208 (defmethod remote-name ((socket socket))
209 (%remote-name socket))
211 (defmethod remote-host ((socket internet-socket))
212 (nth-value 0 (%remote-name socket)))
214 (defmethod remote-port ((socket internet-socket))
215 (nth-value 1 (%remote-name socket)))
217 (defmethod remote-filename ((socket local-socket))
218 (%remote-name socket))
221 ;;;-------------------------------------------------------------------------
222 ;;; BIND
223 ;;;-------------------------------------------------------------------------
225 (defmethod bind-address :before ((socket internet-socket) address
226 &key (reuse-address t))
227 (declare (ignore address))
228 (when reuse-address
229 (setf (socket-option socket :reuse-address) t)))
231 (defun bind-ipv4-address (fd address port)
232 (with-sockaddr-in (sin address port)
233 (%bind fd sin size-of-sockaddr-in)))
235 (defun bind-ipv6-address (fd address port)
236 (with-sockaddr-in6 (sin6 address port)
237 (%bind fd sin6 size-of-sockaddr-in6)))
239 (defmethod bind-address ((socket internet-socket) (address ipv4-address)
240 &key (port 0))
241 (let ((port (ensure-numerical-service port)))
242 (if (ipv6-socket-p socket)
243 (bind-ipv6-address (fd-of socket)
244 (map-ipv4-vector-to-ipv6 (address-name address))
245 port)
246 (bind-ipv4-address (fd-of socket) (address-name address) port)))
247 (values socket))
249 (defmethod bind-address ((socket internet-socket) (address ipv6-address)
250 &key (port 0))
251 (bind-ipv6-address (fd-of socket)
252 (address-name address)
253 (ensure-numerical-service port))
254 (values socket))
256 (defmethod bind-address ((socket local-socket) (address local-address) &key)
257 (with-sockaddr-un (sun (address-name address))
258 (%bind (fd-of socket) sun size-of-sockaddr-un))
259 (values socket))
261 (defmethod bind-address :after ((socket socket) (address address) &key)
262 (setf (slot-value socket 'bound) t))
265 ;;;-------------------------------------------------------------------------
266 ;;; LISTEN
267 ;;;-------------------------------------------------------------------------
269 (defmethod listen-on ((socket passive-socket) &key backlog)
270 (unless backlog (setf backlog (min *default-backlog-size*
271 +max-backlog-size+)))
272 (check-type backlog unsigned-byte "a non-negative integer")
273 (%listen (fd-of socket) backlog)
274 (setf (slot-value socket 'listening) t)
275 (values socket))
277 (defmethod listen-on ((socket active-socket) &key)
278 (error "You can't listen on active sockets."))
281 ;;;-------------------------------------------------------------------------
282 ;;; ACCEPT
283 ;;;-------------------------------------------------------------------------
285 (defmethod accept-connection ((socket active-socket) &key)
286 (error "You can't accept connections on active sockets."))
288 (defmethod accept-connection ((socket passive-socket) &key external-format
289 input-buffer-size output-buffer-size
290 (wait t) (timeout nil))
291 (flet ((make-client-socket (fd)
292 (make-instance (active-class socket)
293 :address-family (socket-address-family socket)
294 :file-descriptor fd
295 :external-format (or external-format
296 (external-format-of socket))
297 :input-buffer-size input-buffer-size
298 :output-buffer-size output-buffer-size)))
299 (ignore-some-conditions (iomux:poll-timeout)
300 (when wait (iomux:wait-until-fd-ready (fd-of socket) :input timeout t))
301 (with-sockaddr-storage-and-socklen (ss size)
302 (ignore-some-conditions (nix:ewouldblock)
303 (make-client-socket (%accept (fd-of socket) ss size)))))))
306 ;;;-------------------------------------------------------------------------
307 ;;; CONNECT
308 ;;;-------------------------------------------------------------------------
310 (defun ipv4-connect (fd address port)
311 (with-sockaddr-in (sin address port)
312 (%connect fd sin size-of-sockaddr-in)))
314 (defun ipv6-connect (fd address port)
315 (with-sockaddr-in6 (sin6 address port)
316 (%connect fd sin6 size-of-sockaddr-in6)))
318 (defun call-with-socket-to-wait-connect (socket thunk wait timeout)
319 (flet
320 ((wait-connect (err)
321 (cond
322 (wait
323 (iomux:wait-until-fd-ready (fd-of socket) :output timeout t)
324 (let ((errcode (socket-option socket :error)))
325 (unless (zerop errcode)
326 (signal-socket-error errcode (fd-of socket)))))
327 (t (error err)))))
328 (handler-case
329 (funcall thunk)
330 (nix:ewouldblock (err) (wait-connect err))
331 (nix:einprogress (err) (wait-connect err)))))
333 (defmacro with-socket-to-wait-connect ((socket wait timeout) &body body)
334 `(call-with-socket-to-wait-connect ,socket (lambda () ,@body) ,wait ,timeout))
336 (defmethod connect ((socket internet-socket) (address inet-address)
337 &key (port 0) (wait t) (timeout nil))
338 (let ((name (address-name address))
339 (port (ensure-numerical-service port)))
340 (with-socket-to-wait-connect (socket wait timeout)
341 (cond
342 ((ipv6-socket-p socket)
343 (when (ipv4-address-p address)
344 (setf name (map-ipv4-vector-to-ipv6 name)))
345 (ipv6-connect (fd-of socket) name port))
346 (t (ipv4-connect (fd-of socket) name port)))))
347 (values socket))
349 (defmethod connect ((socket local-socket) (address local-address) &key)
350 (with-sockaddr-un (sun (address-name address))
351 (%connect (fd-of socket) sun size-of-sockaddr-un))
352 (values socket))
354 (defmethod connect ((socket passive-socket) address &key)
355 (declare (ignore address))
356 (error "You cannot connect passive sockets."))
358 (defmethod socket-connected-p ((socket socket))
359 (when (fd-of socket)
360 (with-sockaddr-storage-and-socklen (ss size)
361 (handler-case
362 (%getpeername (fd-of socket) ss size)
363 (socket-not-connected-error () nil)
364 (:no-error (_) (declare (ignore _)) t)))))
367 ;;;-------------------------------------------------------------------------
368 ;;; DISCONNECT
369 ;;;-------------------------------------------------------------------------
371 (defmethod disconnect :before ((socket socket))
372 (unless (typep socket 'datagram-socket)
373 (error "You can only disconnect active datagram sockets.")))
375 (defmethod disconnect ((socket datagram-socket))
376 (with-foreign-object (sin 'sockaddr-in)
377 (bzero sin size-of-sockaddr-in)
378 (setf (foreign-slot-value sin 'sockaddr-in 'addr) af-unspec)
379 (%connect (fd-of socket) sin size-of-sockaddr-in)
380 (values socket)))
383 ;;;-------------------------------------------------------------------------
384 ;;; SHUTDOWN
385 ;;;-------------------------------------------------------------------------
387 (defmethod shutdown ((socket socket) &key read write)
388 (assert (or read write) (read write)
389 "You must select at least one direction to shut down.")
390 (%shutdown (fd-of socket)
391 (multiple-value-case ((read write))
392 ((* nil) shut-rd)
393 ((nil *) shut-wr)
394 (t shut-rdwr)))
395 (values socket))
398 ;;;-------------------------------------------------------------------------
399 ;;; Socket flag definition
400 ;;;-------------------------------------------------------------------------
402 (defmacro define-socket-flag (place name value platform)
403 (let ((val (cond ((or (not platform)
404 (featurep platform)) value)
405 ((not (featurep platform)) 0))))
406 `(pushnew (cons ,name ,val) ,place)))
408 (defmacro define-socket-flags (place &body definitions)
409 (flet ((dflag (form)
410 (destructuring-bind (name value &optional platform) form
411 `(define-socket-flag ,place ,name ,value ,platform))))
412 `(progn
413 ,@(mapcar #'dflag definitions))))
416 ;;;-------------------------------------------------------------------------
417 ;;; SENDTO
418 ;;;-------------------------------------------------------------------------
420 (defvar *sendto-flags* ())
422 (define-socket-flags *sendto-flags*
423 (:dont-route msg-dontroute)
424 (:dont-wait msg-dontwait (:not :windows))
425 (:out-of-band msg-oob)
426 (:more msg-more :linux)
427 (:confirm msg-confirm :linux))
429 (defun %%send-to (fd ss got-peer buffer start length flags)
430 (with-pointer-to-vector-data (buff-sap buffer)
431 (incf-pointer buff-sap start)
432 (loop
433 (restart-case
434 (return*
435 (%sendto fd buff-sap length flags
436 (if got-peer ss (null-pointer))
437 (if got-peer (sockaddr-size ss) 0)))
438 (ignore ()
439 :report "Ignore this socket condition"
440 (return* 0))
441 (retry (&optional (timeout 15.0d0))
442 :report "Try to send data again"
443 (when (plusp timeout)
444 (iomux:wait-until-fd-ready fd :output timeout nil)))))))
446 (defun %send-to (fd ss got-peer buffer start end flags)
447 (check-bounds buffer start end)
448 (etypecase buffer
449 (ub8-sarray
450 (%%send-to fd ss got-peer buffer start (- end start) flags))
451 ((or ub8-vector (vector t))
452 (%%send-to fd ss got-peer (coerce buffer 'ub8-sarray)
453 start (- end start) flags))))
455 (defmethod send-to ((socket internet-socket) buffer &rest args
456 &key (start 0) end remote-host (remote-port 0) flags (ipv6 *ipv6*))
457 (let ((*ipv6* ipv6))
458 (with-sockaddr-storage (ss)
459 (when remote-host
460 (sockaddr->sockaddr-storage ss (ensure-hostname remote-host)
461 (ensure-numerical-service remote-port)))
462 (%send-to (fd-of socket) ss (if remote-host t) buffer start end
463 (or flags (compute-flags *sendto-flags* args))))))
465 (defmethod send-to ((socket local-socket) buffer &rest args
466 &key (start 0) end remote-filename flags)
467 (with-sockaddr-storage (ss)
468 (when remote-filename
469 (sockaddr->sockaddr-storage ss (ensure-address remote-filename :family :local) 0))
470 (%send-to (fd-of socket) ss (if remote-filename t) buffer start end
471 (or flags (compute-flags *sendto-flags* args)))))
473 (define-compiler-macro send-to (&whole form socket buffer &rest args
474 &key (start 0) end (remote-host nil host-p) (remote-port 0 port-p)
475 (remote-filename nil file-p) flags (ipv6 '*ipv6* ipv6-p) &allow-other-keys)
476 (let ((flags-val (compute-flags *sendto-flags* args)))
477 (cond
478 ((and (not flags) flags-val)
479 (append
480 `(send-to ,socket ,buffer :start ,start :end ,end :flags ,flags-val)
481 (when host-p `(:remote-host ,remote-host))
482 (when port-p `(:remote-port ,remote-port))
483 (when ipv6-p `(:ipv6 ,ipv6))
484 (when file-p `(:remote-filename ,remote-filename))))
486 form))))
489 ;;;-------------------------------------------------------------------------
490 ;;; RECVFROM
491 ;;;-------------------------------------------------------------------------
493 (defvar *recvfrom-flags* ())
495 (define-socket-flags *recvfrom-flags*
496 (:out-of-band msg-oob)
497 (:peek msg-peek)
498 (:wait-all msg-waitall (:not :windows))
499 (:dont-wait msg-dontwait (:not :windows)))
501 (defun %%receive-from (fd ss size buffer start length flags)
502 (with-pointer-to-vector-data (buff-sap buffer)
503 (incf-pointer buff-sap start)
504 (loop
505 (restart-case
506 (return* (%recvfrom fd buff-sap length flags ss size))
507 (ignore ()
508 :report "Ignore this socket condition"
509 (return* 0))
510 (retry (&optional (timeout 15.0d0))
511 :report "Try to receive data again"
512 (when (plusp timeout)
513 (iomux:wait-until-fd-ready fd :input timeout nil)))))))
515 (defun %receive-from (fd ss size buffer start end flags)
516 (check-bounds buffer start end)
517 (flet ((%do-recvfrom (buff start length)
518 (%%receive-from fd ss size buff start length flags)))
519 (let (nbytes)
520 (etypecase buffer
521 (ub8-sarray
522 (setf nbytes (%do-recvfrom buffer start (- end start))))
523 ((or ub8-vector (vector t))
524 (let ((tmpbuff (make-array (- end start) :element-type 'ub8)))
525 (setf nbytes (%do-recvfrom tmpbuff 0 (- end start)))
526 (replace buffer tmpbuff :start1 start :end1 end :start2 0 :end2 nbytes))))
527 (values nbytes))))
529 (defmethod receive-from :around ((socket active-socket) &rest args
530 &key buffer size (start 0) end flags &allow-other-keys)
531 (let ((flags-val (or flags (compute-flags *recvfrom-flags* args))))
532 (cond
533 (buffer
534 (call-next-method socket :buffer buffer :start start :end end :flags flags-val))
536 (check-type size unsigned-byte "a non-negative integer")
537 (call-next-method socket :buffer (make-array size :element-type 'ub8)
538 :start 0 :end size :flags flags-val)))))
540 (defmethod receive-from ((socket stream-socket) &key buffer start end flags)
541 (with-sockaddr-storage-and-socklen (ss size)
542 (let ((nbytes (%receive-from (fd-of socket) ss size buffer start end flags)))
543 (values buffer nbytes))))
545 (defmethod receive-from ((socket datagram-socket) &key buffer start end flags)
546 (with-sockaddr-storage-and-socklen (ss size)
547 (let ((nbytes (%receive-from (fd-of socket) ss size buffer start end flags)))
548 (multiple-value-call #'values buffer nbytes
549 (sockaddr-storage->sockaddr ss)))))
551 (define-compiler-macro receive-from (&whole form socket &rest args
552 &key buffer size (start 0) end flags &allow-other-keys)
553 (let ((flags-val (compute-flags *recvfrom-flags* args)))
554 (cond
555 ((and (not flags) flags-val)
556 `(receive-from ,socket :buffer ,buffer :start ,start :end ,end
557 :size ,size :flags ,flags-val))
559 form))))