1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; socket-methods.lisp --- Various socket methods.
5 ;;; Copyright (C) 2006-2007, Stelian Ionescu <sionescu@common-lisp.net>
7 ;;; This code is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the version 2.1 of
9 ;;; the GNU Lesser General Public License as published by
10 ;;; the Free Software Foundation, as clarified by the
11 ;;; preamble found here:
12 ;;; http://opensource.franz.com/preamble.html
14 ;;; This program is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU Lesser General
20 ;;; Public License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
22 ;;; Boston, MA 02110-1301, USA
24 (in-package :net.sockets
)
26 (defvar *socket-type-map
*
27 '(((:ipv4
:stream
:active
:default
) . socket-stream-internet-active
)
28 ((:ipv6
:stream
:active
:default
) . socket-stream-internet-active
)
29 ((:ipv4
:stream
:passive
:default
) . socket-stream-internet-passive
)
30 ((:ipv6
:stream
:passive
:default
) . socket-stream-internet-passive
)
31 ((:local
:stream
:active
:default
) . socket-stream-local-active
)
32 ((:local
:stream
:passive
:default
) . socket-stream-local-passive
)
33 ((:local
:datagram
:active
:default
) . socket-datagram-local-active
)
34 ((:ipv4
:datagram
:active
:default
) . socket-datagram-internet-active
)
35 ((:ipv6
:datagram
:active
:default
) . socket-datagram-internet-active
)))
37 ;;; FIXME: should match :default to whatever protocol is the default.
38 (defun select-socket-type (family type connect protocol
)
39 (or (cdr (assoc (list family type connect protocol
) *socket-type-map
*
41 (error "No socket class found !!")))
43 ;;;; Shared Initialization
45 (defun translate-make-socket-keywords-to-constants (family type protocol
)
46 (let ((sf (ecase family
52 (:datagram sock-dgram
)))
54 ((integerp protocol
) protocol
)
55 ((eql protocol
:default
) 0)
58 (lookup-protocol (string-downcase (string protocol
))))))))
61 (defmethod socket-fd ((socket socket
))
64 (defmethod (setf socket-fd
) (fd (socket socket
))
65 (setf (fd-of socket
) fd
))
67 ;;; TODO: we should add some sort of finalizer here to avoid leaking
68 ;;; sockets FDs and buffers. Something along these lines:
70 ;;; (trivial-garbage:finalize socket (lambda () (close socket))))
72 ;;; However SBCL's semantics don't allow this, since that reference to
73 ;;; the socket will prevent it from being garbage collected. So we'd
74 ;;; need to get all necessary information into a closure or something
75 ;;; (foreign pointers, FDs, etc) in order to do that closing.
77 ;;; Changed from SHARED-INITIALIZE to INITIALIZE-INSTANCE. Since it
78 ;;; was breaking CHANGE-CLASS. We don't really want to check those
79 ;;; keywords in REINITIALIZE-INSTANCE or do we?
80 (defmethod initialize-instance :after
((socket socket
)
81 &key file-descriptor family type
84 ;; (when (socket-open-p socket)
86 (with-accessors ((fd fd-of
) (fam socket-family
) (proto socket-protocol
))
88 (setf fd
(or file-descriptor
89 (multiple-value-bind (sf st sp
)
90 (translate-make-socket-keywords-to-constants
96 (defmethod (setf external-format-of
) (external-format (socket passive-socket
))
97 (setf (slot-value socket
'external-format
)
98 (babel:ensure-external-format external-format
)))
100 (defmethod initialize-instance :after
((socket passive-socket
)
101 &key external-format
)
102 (setf (external-format-of socket
) external-format
))
104 (defmethod socket-type ((socket stream-socket
))
107 (defmethod socket-type ((socket datagram-socket
))
112 (defun sock-fam (socket)
113 (ecase (socket-family socket
)
117 (defmethod print-object ((socket socket-stream-internet-active
) stream
)
118 (print-unreadable-object (socket stream
:identity t
)
119 (format stream
"active ~A stream socket" (sock-fam socket
))
120 (if (socket-connected-p socket
)
121 (multiple-value-bind (addr port
) (remote-name socket
)
122 (format stream
" connected to ~A/~A"
123 (address-to-string addr
) port
))
124 (format stream
", ~:[closed~;unconnected~]" (fd-of socket
)))))
126 (defmethod print-object ((socket socket-stream-internet-passive
) stream
)
127 (print-unreadable-object (socket stream
:identity t
)
128 (format stream
"passive ~A stream socket" (sock-fam socket
))
129 (if (socket-bound-p socket
)
130 (multiple-value-bind (addr port
) (local-name socket
)
131 (format stream
" ~:[bound to~;waiting @~] ~A/~A"
132 (socket-listening-p socket
)
133 (address-to-string addr
) port
))
134 (format stream
", ~:[closed~;unbound~]" (fd-of socket
)))))
136 (defmethod print-object ((socket socket-stream-local-active
) stream
)
137 (print-unreadable-object (socket stream
:identity t
)
138 (format stream
"active local stream socket")
139 (if (socket-connected-p socket
)
140 (format stream
" connected to ~A"
141 (address-to-string (remote-address socket
)))
142 (format stream
", ~:[closed~;unconnected~]" (fd-of socket
)))))
144 (defmethod print-object ((socket socket-stream-local-passive
) stream
)
145 (print-unreadable-object (socket stream
:identity t
)
146 (format stream
"passive local stream socket")
147 (if (socket-bound-p socket
)
148 (format stream
" ~:[bound to~;waiting @~] ~A"
149 (socket-listening-p socket
)
150 (address-to-string (local-address socket
)))
151 (format stream
", ~:[closed~;unbound~]" (fd-of socket
)))))
153 (defmethod print-object ((socket socket-datagram-local-active
) stream
)
154 (print-unreadable-object (socket stream
:identity t
)
155 (format stream
"local datagram socket")
156 (if (socket-connected-p socket
)
157 (format stream
" connected to ~A"
158 (address-to-string (remote-address socket
)))
159 (format stream
", ~:[closed~;unconnected~]" (fd-of socket
)))))
161 (defmethod print-object ((socket socket-datagram-internet-active
) stream
)
162 (print-unreadable-object (socket stream
:identity t
)
163 (format stream
"~A datagram socket" (sock-fam socket
))
164 (if (socket-connected-p socket
)
165 (multiple-value-bind (addr port
) (remote-name socket
)
166 (format stream
" connected to ~A/~A"
167 (address-to-string addr
) port
))
168 (format stream
", ~:[closed~;unconnected~]" (fd-of socket
)))))
172 (defmethod close :around
((socket socket
) &key abort
)
173 (declare (ignore abort
))
176 (with-socket-error-filter
177 (nix:close
(fd-of socket
))))
178 (setf (fd-of socket
) nil
179 (slot-value socket
'bound
) nil
)
182 (defmethod close :around
((socket passive-socket
) &key abort
)
183 (declare (ignore abort
))
185 (setf (slot-value socket
'listening
) nil
)
188 (defmethod close ((socket socket
) &key abort
)
189 (declare (ignore socket abort
)))
191 ;;; FIXME: this approach doesn't work on windows.
192 (defmethod socket-open-p ((socket socket
))
195 (with-foreign-object (ss 'sockaddr-storage
)
196 (bzero ss size-of-sockaddr-storage
)
197 (with-socklen (size size-of-sockaddr-storage
)
198 (getsockname (fd-of socket
) ss size
)
201 #+freebsd
(nix:econnreset
() nil
)
202 #+windows
(socket-invalid-argument () nil
))))
206 (defmethod local-name ((socket socket
))
207 (with-foreign-object (ss 'sockaddr-storage
)
208 (bzero ss size-of-sockaddr-storage
)
209 (with-socklen (size size-of-sockaddr-storage
)
210 (getsockname (fd-of socket
) ss size
)
211 (sockaddr-storage->sockaddr ss
))))
213 (defmethod local-address ((socket socket
))
214 (nth-value 0 (local-name socket
)))
216 (defmethod local-port ((socket internet-socket
))
217 (nth-value 1 (local-name socket
)))
221 (defmethod remote-name ((socket socket
))
222 (with-foreign-object (ss 'sockaddr-storage
)
223 (bzero ss size-of-sockaddr-storage
)
224 (with-socklen (size size-of-sockaddr-storage
)
225 (getpeername (fd-of socket
) ss size
)
226 (sockaddr-storage->sockaddr ss
))))
228 (defmethod remote-address ((socket socket
))
229 (nth-value 0 (remote-name socket
)))
231 (defmethod remote-port ((socket internet-socket
))
232 (nth-value 1 (remote-name socket
)))
236 (defmethod bind-address :before
((socket internet-socket
) address
237 &key
(reuse-address t
))
238 (declare (ignore address
))
240 (set-socket-option socket
:reuse-address
:value t
)))
242 (defun bind-ipv4-address (fd address port
)
243 (with-sockaddr-in (sin address port
)
244 (bind fd sin size-of-sockaddr-in
)))
246 (defun bind-ipv6-address (fd address port
)
247 (with-sockaddr-in6 (sin6 address port
)
248 (bind fd sin6 size-of-sockaddr-in6
)))
250 (defmethod bind-address ((socket internet-socket
) (address ipv4-address
)
252 (if (eql (socket-family socket
) :ipv6
)
253 (bind-ipv6-address (fd-of socket
)
254 (map-ipv4-vector-to-ipv6 (address-name address
))
256 (bind-ipv4-address (fd-of socket
) (address-name address
) port
))
259 (defmethod bind-address ((socket internet-socket
) (address ipv6-address
)
261 (bind-ipv6-address (fd-of socket
) (address-name address
) port
)
264 (defmethod bind-address ((socket local-socket
) (address local-address
) &key
)
265 #+windows
(error "This platform does not support local sockets.")
267 (with-sockaddr-un (sun (address-name address
))
268 (bind (fd-of socket
) sun size-of-sockaddr-un
))
271 (defmethod bind-address :after
((socket socket
) (address address
) &key
)
272 (setf (slot-value socket
'bound
) t
))
276 (defmethod socket-listen ((socket passive-socket
) &key backlog
)
277 (unless backlog
(setf backlog
(min *default-backlog-size
*
278 +max-backlog-size
+)))
279 (check-type backlog unsigned-byte
"a non-negative integer")
280 (listen (fd-of socket
) backlog
)
281 (setf (slot-value socket
'listening
) t
)
284 (defmethod socket-listen ((socket active-socket
) &key backlog
)
285 (declare (ignore backlog
))
286 (error "You can't listen on active sockets."))
290 (defmethod accept-connection ((socket active-socket
))
291 (error "You can't accept connections on active sockets."))
293 (defmethod accept-connection ((socket passive-socket
))
294 (flet ((make-client-socket (fd)
295 (make-instance (active-class socket
)
296 :external-format
(external-format-of socket
)
297 :file-descriptor fd
)))
298 (with-foreign-object (ss 'sockaddr-storage
)
299 (bzero ss size-of-sockaddr-storage
)
300 (with-socklen (size size-of-sockaddr-storage
)
302 (make-client-socket (accept (fd-of socket
) ss size
))
303 (nix:ewouldblock
()))))))
308 (defmethod connect :before
((socket active-socket
) sockaddr
&key
)
309 (declare (ignore sockaddr
))
310 (set-socket-option socket
:no-sigpipe
:value t
))
312 (defun ipv4-connect (fd address port
)
313 (with-sockaddr-in (sin address port
)
314 (%connect fd sin size-of-sockaddr-in
)))
316 (defun ipv6-connect (fd address port
)
317 (with-sockaddr-in6 (sin6 address port
)
318 (%connect fd sin6 size-of-sockaddr-in6
)))
320 (defmethod connect ((socket internet-socket
) (address ipv4-address
)
322 (if (eql (socket-family socket
) :ipv6
)
323 (ipv6-connect (fd-of socket
)
324 (map-ipv4-vector-to-ipv6 (address-name address
))
326 (ipv4-connect (fd-of socket
) (address-name address
) port
))
329 (defmethod connect ((socket internet-socket
) (address ipv6-address
)
331 (ipv6-connect (fd-of socket
) (address-name address
) port
)
334 (defmethod connect ((socket local-socket
) (address local-address
) &key
)
336 (error "This platform does not support local sockets.")
338 (with-sockaddr-un (sun (address-name address
))
339 (%connect
(fd-of socket
) sun size-of-sockaddr-un
))
342 (defmethod connect ((socket passive-socket
) address
&key
)
343 (declare (ignore address
))
344 (error "You cannot connect passive sockets."))
346 (defmethod socket-connected-p ((socket socket
))
349 (with-foreign-object (ss 'sockaddr-storage
)
350 (bzero ss size-of-sockaddr-storage
)
351 (with-socklen (size size-of-sockaddr-storage
)
352 (getpeername (fd-of socket
) ss size
)
354 (socket-not-connected-error () nil
))))
358 (defmethod shutdown ((socket active-socket
) direction
)
359 (check-type direction
(member :read
:write
:read-write
)
360 "valid direction specifier")
361 (%shutdown
(fd-of socket
)
365 (:read-write shut-rdwr
)))
368 (defmethod shutdown ((socket passive-socket
) direction
)
369 (declare (ignore direction
))
370 (error "You cannot shut down passive sockets."))
374 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
375 (defun compute-flags (flags args
)
376 (loop :with flag-combination
:= 0
377 :for cons
:on args
:by
#'cddr
378 :for flag
:= (car cons
)
379 :for val
:= (cadr cons
)
380 :for const
:= (cdr (assoc flag flags
))
382 (when (not (constantp val
)) (return-from compute-flags
))
383 (setf flag-combination
(logior flag-combination const
))
384 :finally
(return flag-combination
)))
386 (defmacro define-socket-flag
(place name value platform
)
387 (let ((val (cond ((or (not platform
)
388 (featurep platform
)) value
)
389 ((not (featurep platform
) 0)))))
390 `(push (cons ,name
,val
) ,place
))))
392 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
393 (defparameter *sendmsg-flags
* nil
)
395 (defmacro define-sendmsg-flags
(&rest forms
)
397 (destructuring-bind (name value
&optional platform
) form
398 `(define-socket-flag *sendmsg-flags
* ,name
,value
,platform
))))
400 ,@(mapcar #'dflag forms
))))
402 (define-sendmsg-flags
403 (:end-of-record msg-eor
(:not
:windows
))
404 (:dont-route msg-dontroute
)
405 (:dont-wait msg-dontwait
(:not
:windows
))
406 (:no-signal msg-nosignal
(:not
(:or
:darwin
:windows
)))
407 (:out-of-band msg-oob
)
408 (:more msg-more
:linux
)
409 (:confirm msg-confirm
:linux
)))
411 (defun %normalize-send-buffer
(buff start end ef
)
412 (check-bounds buff start end
)
414 (ub8-sarray (values buff start
(- end start
)))
415 (ub8-vector (values (coerce buff
'ub8-sarray
)
416 start
(- end start
)))
417 (string (values (%to-octets buff ef start end
)
419 (vector (values (coerce buff
'ub8-sarray
)
420 start
(- end start
)))))
422 (defun %socket-send
(buffer socket start end remote-address remote-port flags
)
423 (when (typep socket
'passive-socket
)
424 (error "You cannot send data on a passive socket."))
425 (check-type start unsigned-byte
"a non-negative unsigned integer")
426 (check-type end
(or unsigned-byte null
) "a non-negative unsigned integer or NIL")
427 (check-type remote-address
(or address null
) "a network address or NIL")
428 (check-type remote-port
(unsigned-byte 16) "a valid IP port number")
429 (when (and (ipv4-address-p remote-address
)
430 (eq (socket-family socket
) :ipv6
))
431 (setf remote-address
(map-ipv4-address-to-ipv6 remote-address
)))
432 (multiple-value-bind (buff start-offset bufflen
)
433 (%normalize-send-buffer buffer start end
(external-format-of socket
))
434 (with-foreign-object (ss 'sockaddr-storage
)
435 (bzero ss size-of-sockaddr-storage
)
437 (sockaddr->sockaddr-storage ss remote-address remote-port
))
438 (with-pointer-to-vector-data (buff-sap buff
)
439 (incf-pointer buff-sap start-offset
)
440 (sendto (fd-of socket
) buff-sap bufflen flags
441 (if remote-address ss
(null-pointer))
442 (if remote-address size-of-sockaddr-storage
0))))))
444 (defmethod socket-send ((buffer array
) (socket active-socket
) &rest args
445 &key
(start 0) end remote-address
(remote-port 0) &allow-other-keys
)
446 (%socket-send buffer socket start end remote-address remote-port
447 (compute-flags *sendmsg-flags
* args
)))
449 (define-compiler-macro socket-send
(&whole form buffer socket
&rest args
450 &key
(start 0) end remote-address
(remote-port 0)
452 (let ((flags (compute-flags *sendmsg-flags
* args
)))
453 (cond (flags `(%socket-send
,buffer
,socket
,start
,end
454 ,remote-address
,remote-port
,flags
))
459 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
460 (defparameter *recvfrom-flags
* nil
)
462 (defmacro define-recvfrom-flags
(&rest forms
)
464 (destructuring-bind (name value
&optional platform
) form
465 `(define-socket-flag *recvfrom-flags
* ,name
,value
,platform
))))
467 ,@(mapcar #'dflag forms
))))
469 (define-recvfrom-flags
470 (:out-of-band msg-oob
)
472 (:wait-all msg-waitall
(:not
:windows
))
473 (:dont-wait msg-dontwait
(:not
:windows
))
474 (:no-signal msg-nosignal
(:not
(:or
:darwin
:windows
)))))
476 (defun %normalize-receive-buffer
(buff start end
)
477 (check-bounds buff start end
)
479 ((simple-array ub8
(*)) (values buff start
(- end start
)))))
481 (defun %socket-receive-bytes
(buffer ss fd flags start end
)
482 (multiple-value-bind (buff start-offset bufflen
)
483 (%normalize-receive-buffer buffer start end
)
484 (with-socklen (size size-of-sockaddr-storage
)
485 (bzero ss size-of-sockaddr-storage
)
486 (with-pointer-to-vector-data (buff-sap buff
)
487 (incf-pointer buff-sap start-offset
)
488 (recvfrom fd buff-sap bufflen flags ss size
)))))
490 (declaim (inline %socket-receive-stream-socket
))
491 (defun %socket-receive-stream-socket
(buffer socket start end flags
)
492 (with-foreign-object (ss 'sockaddr-storage
)
493 (let ((bytes-received (%socket-receive-bytes buffer ss
(fd-of socket
) flags
495 (values buffer bytes-received
))))
497 (declaim (inline %socket-receive-datagram-socket
))
498 (defun %socket-receive-datagram-socket
(buffer socket start end flags
)
499 (with-foreign-object (ss 'sockaddr-storage
)
500 (let ((bytes-received (%socket-receive-bytes buffer ss
(fd-of socket
) flags
502 (multiple-value-bind (remote-address remote-port
)
503 (sockaddr-storage->sockaddr ss
)
504 (values buffer bytes-received remote-address remote-port
)))))
506 (defun %socket-receive
(buffer socket start end flags
)
507 (when (typep socket
'passive-socket
)
508 (error "You cannot receive data from a passive socket."))
510 (stream-socket (%socket-receive-stream-socket
511 buffer socket start end flags
))
512 (datagram-socket (%socket-receive-datagram-socket
513 buffer socket start end flags
))))
515 (defmethod socket-receive ((buffer array
) (socket active-socket
)
516 &rest args
&key
(start 0) end flags
&allow-other-keys
)
517 (%socket-receive buffer socket start end
518 (compute-flags *recvfrom-flags
* args
)))
520 (define-compiler-macro socket-receive
(&whole form buffer socket
&rest args
521 &key
(start 0) end flags
&allow-other-keys
)
522 (let ((flags (compute-flags *recvfrom-flags
* args
)))
523 (cond (flags `(%socket-receive
,buffer
,socket
,start
,end
,flags
))
526 ;;;; Datagram Sockets
528 (defmethod disconnect :before
((socket active-socket
))
529 (unless (typep socket
'datagram-socket
)
530 (error "You can only disconnect active datagram sockets.")))
532 (defmethod disconnect ((socket datagram-socket
))
533 (with-foreign-object (sin 'sockaddr-in
)
534 (bzero sin size-of-sockaddr-in
)
535 (setf (foreign-slot-value sin
'sockaddr-in
'addr
) af-unspec
)
536 (%connect
(fd-of socket
) sin size-of-sockaddr-in
)))