1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; socket-methods.lisp --- Various socket methods.
5 ;;; Copyright (C) 2006-2008, 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-class (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 ((eq :default protocol
) 0)
56 (t (lookup-protocol protocol
)))))
59 (defmethod socket-fd ((socket socket
))
62 (defmethod (setf socket-fd
) (fd (socket socket
))
63 (setf (fd-of socket
) fd
))
65 (defmethod initialize-instance :after
((socket socket
) &key
66 file-descriptor family type
68 (with-accessors ((fd fd-of
) (fam socket-family
) (proto socket-protocol
))
70 (setf fd
(or file-descriptor
71 (multiple-value-call #'%socket
72 (translate-make-socket-keywords-to-constants
73 family type protocol
))))
77 (defmethod (setf external-format-of
) (external-format (socket passive-socket
))
78 (setf (slot-value socket
'external-format
)
79 (babel:ensure-external-format external-format
)))
81 (defmethod initialize-instance :after
((socket passive-socket
)
83 (setf (external-format-of socket
) external-format
))
85 (defmethod socket-type ((socket stream-socket
))
88 (defmethod socket-type ((socket datagram-socket
))
93 (defun sock-fam (socket)
94 (ecase (socket-family socket
)
98 (defmethod print-object ((socket socket-stream-internet-active
) stream
)
99 (print-unreadable-object (socket stream
:identity t
)
100 (format stream
"active ~A stream socket" (sock-fam socket
))
101 (if (socket-connected-p socket
)
102 (multiple-value-bind (addr port
) (remote-name socket
)
103 (format stream
" connected to ~A/~A"
104 (address-to-string addr
) port
))
105 (format stream
", ~:[closed~;unconnected~]" (fd-of socket
)))))
107 (defmethod print-object ((socket socket-stream-internet-passive
) stream
)
108 (print-unreadable-object (socket stream
:identity t
)
109 (format stream
"passive ~A stream socket" (sock-fam socket
))
110 (if (socket-bound-p socket
)
111 (multiple-value-bind (addr port
) (local-name socket
)
112 (format stream
" ~:[bound to~;waiting @~] ~A/~A"
113 (socket-listening-p socket
)
114 (address-to-string addr
) port
))
115 (format stream
", ~:[closed~;unbound~]" (fd-of socket
)))))
117 (defmethod print-object ((socket socket-stream-local-active
) stream
)
118 (print-unreadable-object (socket stream
:identity t
)
119 (format stream
"active local stream socket")
120 (if (socket-connected-p socket
)
121 (format stream
" connected to ~S"
122 (address-to-string (remote-address socket
)))
123 (format stream
", ~:[closed~;unconnected~]" (fd-of socket
)))))
125 (defmethod print-object ((socket socket-stream-local-passive
) stream
)
126 (print-unreadable-object (socket stream
:identity t
)
127 (format stream
"passive local stream socket")
128 (if (socket-bound-p socket
)
129 (format stream
" ~:[bound to~;waiting @~] ~S"
130 (socket-listening-p socket
)
131 (address-to-string (local-address socket
)))
132 (format stream
", ~:[closed~;unbound~]" (fd-of socket
)))))
134 (defmethod print-object ((socket socket-datagram-local-active
) stream
)
135 (print-unreadable-object (socket stream
:identity t
)
136 (format stream
"local datagram socket")
137 (if (socket-connected-p socket
)
138 (format stream
" connected to ~S"
139 (address-to-string (remote-address socket
)))
141 (format stream
" waiting @ ~S" (address-to-string (local-address socket
)))
142 (format stream
", closed" )))))
144 (defmethod print-object ((socket socket-datagram-internet-active
) stream
)
145 (print-unreadable-object (socket stream
:identity t
)
146 (format stream
"~A datagram socket" (sock-fam socket
))
147 (if (socket-connected-p socket
)
148 (multiple-value-bind (addr port
) (remote-name socket
)
149 (format stream
" connected to ~A/~A"
150 (address-to-string addr
) port
))
152 (multiple-value-bind (addr port
) (local-name socket
)
153 (format stream
" waiting @ ~A/~A"
154 (address-to-string addr
) port
))
155 (format stream
", closed" )))))
159 (defmethod close :around
((socket socket
) &key abort
)
160 (declare (ignore abort
))
163 (nix:close
(fd-of socket
)))
164 (setf (fd-of socket
) nil
165 (slot-value socket
'bound
) nil
)
168 (defmethod close :around
((socket passive-socket
) &key abort
)
169 (declare (ignore abort
))
171 (setf (slot-value socket
'listening
) nil
)
174 (defmethod close ((socket socket
) &key abort
)
175 (declare (ignore socket abort
)))
177 (defmethod socket-open-p ((socket socket
))
179 (with-sockaddr-storage (ss)
180 (with-socklen (size size-of-sockaddr-storage
)
182 (%getsockname
(fd-of socket
) ss size
)
184 (nix:econnreset
() nil
)
185 (:no-error
(_) (declare (ignore _
)) t
))))))
189 (defmethod local-name ((socket socket
))
190 (with-sockaddr-storage (ss)
191 (with-socklen (size size-of-sockaddr-storage
)
192 (%getsockname
(fd-of socket
) ss size
)
193 (sockaddr-storage->sockaddr ss
))))
195 (defmethod local-address ((socket socket
))
196 (nth-value 0 (local-name socket
)))
198 (defmethod local-port ((socket internet-socket
))
199 (nth-value 1 (local-name socket
)))
203 (defmethod remote-name ((socket socket
))
204 (with-sockaddr-storage (ss)
205 (with-socklen (size size-of-sockaddr-storage
)
206 (%getpeername
(fd-of socket
) ss size
)
207 (sockaddr-storage->sockaddr ss
))))
209 (defmethod remote-address ((socket socket
))
210 (nth-value 0 (remote-name socket
)))
212 (defmethod remote-port ((socket internet-socket
))
213 (nth-value 1 (remote-name socket
)))
217 (defmethod bind-address :before
((socket internet-socket
) address
218 &key
(reuse-address t
))
219 (declare (ignore address
))
221 (setf (socket-option socket
:reuse-address
) t
)))
223 (defun bind-ipv4-address (fd address port
)
224 (with-sockaddr-in (sin address port
)
225 (%bind fd sin size-of-sockaddr-in
)))
227 (defun bind-ipv6-address (fd address port
)
228 (with-sockaddr-in6 (sin6 address port
)
229 (%bind fd sin6 size-of-sockaddr-in6
)))
231 (defmethod bind-address ((socket internet-socket
) (address ipv4-address
)
233 (if (eq :ipv6
(socket-family socket
))
234 (bind-ipv6-address (fd-of socket
)
235 (map-ipv4-vector-to-ipv6 (address-name address
))
237 (bind-ipv4-address (fd-of socket
) (address-name address
) port
))
240 (defmethod bind-address ((socket internet-socket
) (address ipv6-address
)
242 (bind-ipv6-address (fd-of socket
) (address-name address
) port
)
245 (defmethod bind-address ((socket local-socket
) (address local-address
) &key
)
246 (with-sockaddr-un (sun (address-name address
))
247 (%bind
(fd-of socket
) sun size-of-sockaddr-un
))
250 (defmethod bind-address :after
((socket socket
) (address address
) &key
)
251 (setf (slot-value socket
'bound
) t
))
255 (defmethod socket-listen ((socket passive-socket
) &key backlog
)
256 (unless backlog
(setf backlog
(min *default-backlog-size
*
257 +max-backlog-size
+)))
258 (check-type backlog unsigned-byte
"a non-negative integer")
259 (%listen
(fd-of socket
) backlog
)
260 (setf (slot-value socket
'listening
) t
)
263 (defmethod socket-listen ((socket active-socket
) &key
)
264 (error "You can't listen on active sockets."))
268 (defmethod accept-connection ((socket active-socket
) &key
)
269 (error "You can't accept connections on active sockets."))
271 (defmethod accept-connection ((socket passive-socket
) &key external-format
272 input-buffer-size output-buffer-size
)
273 (flet ((make-client-socket (fd)
274 (make-instance (active-class socket
)
276 :external-format
(or external-format
277 (external-format-of socket
))
278 :input-buffer-size input-buffer-size
279 :output-buffer-size output-buffer-size
)))
280 (with-sockaddr-storage (ss)
281 (with-socklen (size size-of-sockaddr-storage
)
283 (make-client-socket (%accept
(fd-of socket
) ss size
))
284 (nix:ewouldblock
()))))))
289 (defmethod connect :before
((socket active-socket
) sockaddr
&key
)
290 (declare (ignore sockaddr
))
291 (setf (socket-option socket
:no-sigpipe
) t
))
293 (defun ipv4-connect (fd address port
)
294 (with-sockaddr-in (sin address port
)
295 (%connect fd sin size-of-sockaddr-in
)))
297 (defun ipv6-connect (fd address port
)
298 (with-sockaddr-in6 (sin6 address port
)
299 (%connect fd sin6 size-of-sockaddr-in6
)))
301 (defmethod connect ((socket internet-socket
) (address ipv4-address
)
303 (if (eq :ipv6
(socket-family socket
))
304 (ipv6-connect (fd-of socket
)
305 (map-ipv4-vector-to-ipv6 (address-name address
))
307 (ipv4-connect (fd-of socket
) (address-name address
) port
))
310 (defmethod connect ((socket internet-socket
) (address ipv6-address
)
312 (ipv6-connect (fd-of socket
) (address-name address
) port
)
315 (defmethod connect ((socket local-socket
) (address local-address
) &key
)
316 (with-sockaddr-un (sun (address-name address
))
317 (%connect
(fd-of socket
) sun size-of-sockaddr-un
))
320 (defmethod connect ((socket passive-socket
) address
&key
)
321 (declare (ignore address
))
322 (error "You cannot connect passive sockets."))
324 (defmethod socket-connected-p ((socket socket
))
326 (with-sockaddr-storage (ss)
327 (with-socklen (size size-of-sockaddr-storage
)
329 (%getpeername
(fd-of socket
) ss size
)
330 (socket-not-connected-error () nil
)
331 (:no-error
(_) (declare (ignore _
)) t
))))))
335 (defmethod shutdown ((socket socket
) &key read write
)
336 (assert (or read write
) (read write
)
337 "You must select at least one direction to shut down.")
338 (%shutdown
(fd-of socket
)
339 (multiple-value-case (read write
)
347 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
348 (defun compute-flags (flags args
)
349 (loop :with flag-combination
:= 0
350 :for cons
:on args
:by
#'cddr
351 :for flag
:= (car cons
)
352 :for val
:= (cadr cons
)
353 :for const
:= (cdr (assoc flag flags
))
355 (when (not (constantp val
)) (return-from compute-flags
))
356 (setf flag-combination
(logior flag-combination const
))
357 :finally
(return flag-combination
)))
359 (defmacro define-socket-flag
(place name value platform
)
360 (let ((val (cond ((or (not platform
)
361 (featurep platform
)) value
)
362 ((not (featurep platform
)) 0))))
363 `(push (cons ,name
,val
) ,place
))))
365 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
366 (defparameter *sendmsg-flags
* nil
)
368 (defmacro define-sendmsg-flags
(&rest forms
)
370 (destructuring-bind (name value
&optional platform
) form
371 `(define-socket-flag *sendmsg-flags
* ,name
,value
,platform
))))
373 ,@(mapcar #'dflag forms
))))
375 (define-sendmsg-flags
376 (:end-of-record msg-eor
(:not
:windows
))
377 (:dont-route msg-dontroute
)
378 (:dont-wait msg-dontwait
(:not
:windows
))
379 (:no-signal msg-nosignal
(:not
(:or
:darwin
:windows
)))
380 (:out-of-band msg-oob
)
381 (:more msg-more
:linux
)
382 (:confirm msg-confirm
:linux
)))
384 (defun %normalize-send-buffer
(buff start end ef
)
385 (check-bounds buff start end
)
387 (ub8-sarray (values buff start
(- end start
)))
388 (ub8-vector (values (coerce buff
'ub8-sarray
)
389 start
(- end start
)))
390 (string (values (%to-octets buff ef start end
)
392 (vector (values (coerce buff
'ub8-sarray
)
393 start
(- end start
)))))
395 (defun %send-to
(socket buffer start end remote-address remote-port flags
)
396 (when (typep socket
'passive-socket
)
397 (error "You cannot send data on a passive socket."))
398 (when remote-address
(setf remote-address
(ensure-hostname remote-address
)))
399 (when remote-port
(setf remote-port
(ensure-numerical-service remote-port
)))
400 (when (and (ipv4-address-p remote-address
)
401 (eq :ipv6
(socket-family socket
)))
402 (setf remote-address
(map-ipv4-address-to-ipv6 remote-address
)))
403 (multiple-value-bind (buff start-offset bufflen
)
404 (%normalize-send-buffer buffer start end
(external-format-of socket
))
405 (with-sockaddr-storage (ss)
407 (sockaddr->sockaddr-storage ss remote-address remote-port
))
408 (with-pointer-to-vector-data (buff-sap buff
)
409 (incf-pointer buff-sap start-offset
)
410 (%sendto
(fd-of socket
) buff-sap bufflen flags
411 (if remote-address ss
(null-pointer))
412 (if remote-address size-of-sockaddr-storage
0))))))
414 (defmethod send-to ((socket active-socket
) buffer
&rest args
415 &key
(start 0) end remote-address
(remote-port 0) (ipv6 *ipv6
*))
417 (%send-to socket buffer start end remote-address remote-port
418 (compute-flags *sendmsg-flags
* args
))))
420 (define-compiler-macro send-to
(&whole form socket buffer
&rest args
421 &key
(start 0) end remote-address
(remote-port 0)
422 (ipv6 '*ipv6
* ipv6p
))
423 (let ((flags (compute-flags *sendmsg-flags
* args
)))
424 (cond (flags (if ipv6p
425 `(let ((*ipv6
* ,ipv6
))
426 (%send-to
,socket
,buffer
,start
,end
427 ,remote-address
,remote-port
,flags
))
428 `(%send-to
,socket
,buffer
,start
,end
429 ,remote-address
,remote-port
,flags
)))
434 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
435 (defparameter *recvfrom-flags
* nil
)
437 (defmacro define-recvfrom-flags
(&rest forms
)
439 (destructuring-bind (name value
&optional platform
) form
440 `(define-socket-flag *recvfrom-flags
* ,name
,value
,platform
))))
442 ,@(mapcar #'dflag forms
))))
444 (define-recvfrom-flags
445 (:out-of-band msg-oob
)
447 (:wait-all msg-waitall
(:not
:windows
))
448 (:dont-wait msg-dontwait
(:not
:windows
))
449 (:no-signal msg-nosignal
(:not
(:or
:darwin
:windows
)))))
451 (defun %normalize-receive-buffer
(buff start end
)
452 (check-bounds buff start end
)
454 (ub8-sarray (values buff start
(- end start
)))))
456 (defun %socket-receive-bytes
(fd buffer start end flags ss
)
457 (multiple-value-bind (buff start-offset bufflen
)
458 (%normalize-receive-buffer buffer start end
)
459 (with-socklen (size size-of-sockaddr-storage
)
460 (bzero ss size-of-sockaddr-storage
)
461 (with-pointer-to-vector-data (buff-sap buff
)
462 (incf-pointer buff-sap start-offset
)
463 (%recvfrom fd buff-sap bufflen flags ss size
)))))
465 (declaim (inline %receive-from-stream-socket
))
466 (defun %receive-from-stream-socket
(socket buffer start end flags
)
467 (with-sockaddr-storage (ss)
468 (let ((bytes-received (%socket-receive-bytes
(fd-of socket
) buffer
469 start end flags ss
)))
470 (values buffer bytes-received
))))
472 (declaim (inline %receive-from-datagram-socket
))
473 (defun %receive-from-datagram-socket
(socket buffer start end flags
)
474 (with-sockaddr-storage (ss)
475 (let ((bytes-received (%socket-receive-bytes
(fd-of socket
) buffer
476 start end flags ss
)))
477 (multiple-value-bind (remote-address remote-port
)
478 (sockaddr-storage->sockaddr ss
)
479 (values buffer bytes-received remote-address remote-port
)))))
481 (defun %receive-from
(socket buffer start end size flags
)
483 (check-type size unsigned-byte
"a non-negative integer")
484 (setf buffer
(make-array size
:element-type
'ub8
)
487 (stream-socket (%receive-from-stream-socket socket buffer start end flags
))
488 (datagram-socket (%receive-from-datagram-socket socket buffer start end flags
))))
490 (defmethod receive-from ((socket active-socket
) &rest args
491 &key buffer size
(start 0) end
)
492 (%receive-from socket buffer start end size
493 (compute-flags *recvfrom-flags
* args
)))
495 (define-compiler-macro receive-from
(&whole form socket
&rest args
496 &key buffer size
(start 0) end
)
497 (let ((flags (compute-flags *recvfrom-flags
* args
)))
498 (cond (flags `(%receive-from
,socket
,buffer
,start
,end
,size
,flags
))
501 ;;;; Datagram Sockets
503 (defmethod disconnect :before
((socket active-socket
))
504 (unless (typep socket
'datagram-socket
)
505 (error "You can only disconnect active datagram sockets.")))
507 (defmethod disconnect ((socket datagram-socket
))
508 (with-foreign-object (sin 'sockaddr-in
)
509 (bzero sin size-of-sockaddr-in
)
510 (setf (foreign-slot-value sin
'sockaddr-in
'addr
) af-unspec
)
511 (%connect
(fd-of socket
) sin size-of-sockaddr-in
)))