1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
3 ;; Copyright (C) 2006, 2007 Stelian Ionescu
5 ;; This code is free software; you can redistribute it and/or
6 ;; modify it under the terms of the version 2.1 of
7 ;; the GNU Lesser General Public License as published by
8 ;; the Free Software Foundation, as clarified by the
9 ;; preamble found here:
10 ;; http://opensource.franz.com/preamble.html
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU Lesser General
18 ;; Public License along with this library; if not, write to the
19 ;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
20 ;; Boston, MA 02110-1301, USA
22 (in-package :net.sockets
)
24 (defvar *socket-type-map
*
25 '(((:ipv4
:stream
:active
:default
) . socket-stream-internet-active
)
26 ((:ipv6
:stream
:active
:default
) . socket-stream-internet-active
)
27 ((:ipv4
:stream
:passive
:default
) . socket-stream-internet-passive
)
28 ((:ipv6
:stream
:passive
:default
) . socket-stream-internet-passive
)
29 ((:local
:stream
:active
:default
) . socket-stream-local-active
)
30 ((:local
:stream
:passive
:default
) . socket-stream-local-passive
)
31 ((:local
:datagram
:active
:default
) . socket-datagram-local-active
)
32 ((:ipv4
:datagram
:active
:default
) . socket-datagram-internet-active
)
33 ((:ipv6
:datagram
:active
:default
) . socket-datagram-internet-active
)))
35 (defun select-socket-type (family type connect protocol
)
36 (or (cdr (assoc (list family type connect protocol
) *socket-type-map
*
38 (error "No socket class found !!")))
41 ;;;;;;;;;;;;;;;;;;;;;;;;;
42 ;; SHARED-INITIALIZE ;;
43 ;;;;;;;;;;;;;;;;;;;;;;;;;
45 (defun translate-make-socket-keywords-to-constants (family type protocol
)
46 (let ((sf (ecase family
49 (:local et
:af-local
)))
51 (:stream et
:sock-stream
)
52 (:datagram et
:sock-dgram
)))
54 ((integerp protocol
) protocol
)
55 ((eql protocol
:default
) 0)
58 (get-protocol-by-name (string-downcase
59 (string protocol
))))))))
62 (defmethod socket-fd ((socket socket
))
64 (defmethod (setf socket-fd
) (fd (socket socket
))
65 (setf (fd-of socket
) fd
))
67 (defmethod shared-initialize :after
((socket socket
) slot-names
68 &key file-descriptor family
69 type
(protocol :default
))
70 (declare (ignore slot-names
))
71 (when (socket-open-p socket
)
73 (with-accessors ((fd fd-of
)
75 (proto socket-protocol
)) socket
76 (setf fd
(or file-descriptor
77 (multiple-value-bind (sf st sp
)
78 (translate-make-socket-keywords-to-constants family type protocol
)
79 (with-socket-error-filter
80 (et:socket sf st sp
)))))
84 (defmethod socket-type ((socket stream-socket
))
87 (defmethod socket-type ((socket datagram-socket
))
95 (defmethod print-object ((socket socket-stream-internet-active
) stream
)
96 (print-unreadable-object (socket stream
:type nil
:identity t
)
97 (format stream
"active internet stream socket" )
98 (if (socket-connected-p socket
)
99 (multiple-value-bind (addr port
) (remote-name socket
)
100 (format stream
" connected to ~A/~A"
101 (sockaddr->presentation addr
) port
))
103 (format stream
", unconnected")
104 (format stream
", closed")))))
106 (defmethod print-object ((socket socket-stream-internet-passive
) stream
)
107 (print-unreadable-object (socket stream
:type nil
:identity t
)
108 (format stream
"passive internet stream socket" )
109 (if (socket-bound-p socket
)
110 (multiple-value-bind (addr port
) (local-name socket
)
111 (format stream
" ~A ~A/~A"
112 (if (socket-listening-p socket
)
113 "waiting for connections @"
115 (sockaddr->presentation addr
) port
))
117 (format stream
", unbound")
118 (format stream
", closed")))))
120 (defmethod print-object ((socket socket-stream-local-active
) stream
)
121 (print-unreadable-object (socket stream
:type nil
:identity t
)
122 (format stream
"active local stream socket" )
123 (if (socket-connected-p socket
)
124 (format stream
" connected")
126 (format stream
", unconnected")
127 (format stream
", closed")))))
129 (defmethod print-object ((socket socket-stream-local-passive
) stream
)
130 (print-unreadable-object (socket stream
:type nil
:identity t
)
131 (format stream
"passive local stream socket" )
132 (if (socket-bound-p socket
)
133 (format stream
" ~A ~A"
134 (if (socket-listening-p socket
)
135 "waiting for connections @"
137 (sockaddr->presentation
(socket-address socket
)))
139 (format stream
", unbound")
140 (format stream
", closed")))))
142 (defmethod print-object ((socket socket-datagram-local-active
) stream
)
143 (print-unreadable-object (socket stream
:type nil
:identity t
)
144 (format stream
"local datagram socket" )
145 (if (socket-connected-p socket
)
146 (format stream
" connected")
148 (format stream
", unconnected")
149 (format stream
", closed")))))
151 (defmethod print-object ((socket socket-datagram-internet-active
) stream
)
152 (print-unreadable-object (socket stream
:type nil
:identity t
)
153 (format stream
"internet datagram socket" )
154 (if (socket-connected-p socket
)
155 (multiple-value-bind (addr port
) (remote-name socket
)
156 (format stream
" connected to ~A/~A"
157 (sockaddr->presentation addr
) port
))
159 (format stream
", unconnected")
160 (format stream
", closed")))))
167 (defmethod close :around
((socket socket
) &key abort
)
168 (declare (ignore abort
))
170 (with-socket-error-filter
171 (et:close
(fd-of socket
))))
172 (setf (fd-of socket
) nil
)
176 (defmethod close :around
((socket passive-socket
) &key abort
)
177 (declare (ignore abort
))
179 (setf (slot-value socket
'bound
) nil
)
180 (setf (slot-value socket
'listening
) nil
)
183 (defmethod close ((socket socket
) &key abort
)
184 (declare (ignore socket abort
)))
186 (defmethod socket-open-p ((socket socket
))
187 (unless (fd-of socket
)
188 (return-from socket-open-p nil
))
189 (with-socket-error-filter
191 (with-foreign-object (ss 'et
:sockaddr-storage
)
192 (et:bzero ss et
:size-of-sockaddr-storage
)
193 (with-foreign-pointer (size et
:size-of-socklen
)
194 (setf (mem-ref size
:socklen
)
195 et
:size-of-sockaddr-storage
)
196 (et:getsockname
(fd-of socket
) ss size
)
199 (case (error-identifier err
)
201 #+freebsd
:econnreset
)
204 (otherwise (error err
)))))))
211 (defmethod local-name ((socket internet-socket
))
212 (with-foreign-object (ss 'et
:sockaddr-storage
)
213 (et:bzero ss et
:size-of-sockaddr-storage
)
214 (with-foreign-pointer (size et
:size-of-socklen
)
215 (setf (mem-ref size
:socklen
)
216 et
:size-of-sockaddr-storage
)
217 (with-socket-error-filter
218 (et:getsockname
(fd-of socket
) ss size
))
219 (return-from local-name
220 (sockaddr-storage->sockaddr ss
)))))
222 (defmethod local-name ((socket local-socket
))
223 (with-foreign-object (sun 'et
:sockaddr-un
)
224 (et:bzero sun et
:size-of-sockaddr-un
)
225 (with-foreign-pointer (size et
:size-of-socklen
)
226 (setf (mem-ref size
:socklen
)
227 et
:size-of-sockaddr-storage
)
228 (with-socket-error-filter
229 (et:getsockname
(fd-of socket
) sun size
))
230 (return-from local-name
231 (sockaddr-un->sockaddr sun
)))))
233 (defmethod socket-address ((socket socket
))
234 (nth-value 0 (local-name socket
)))
236 (defmethod socket-port ((socket internet-socket
))
237 (nth-value 1 (local-name socket
)))
244 (defmethod remote-name ((socket internet-socket
))
245 (with-foreign-object (ss 'et
:sockaddr-storage
)
246 (et:bzero ss et
:size-of-sockaddr-storage
)
247 (with-foreign-pointer (size et
:size-of-socklen
)
248 (setf (mem-ref size
:socklen
)
249 et
:size-of-sockaddr-storage
)
250 (with-socket-error-filter
251 (et:getpeername
(fd-of socket
) ss size
))
252 (return-from remote-name
253 (sockaddr-storage->sockaddr ss
)))))
255 (defmethod remote-name ((socket local-socket
))
256 (with-foreign-object (sun 'et
:sockaddr-un
)
257 (et:bzero sun et
:size-of-sockaddr-un
)
258 (with-foreign-pointer (size et
:size-of-socklen
)
259 (setf (mem-ref size
:socklen
)
260 et
:size-of-sockaddr-storage
)
261 (with-socket-error-filter
262 (et:getpeername
(fd-of socket
) sun size
))
263 (return-from remote-name
264 (sockaddr-un->sockaddr sun
)))))
271 (defmethod bind-address :before
((socket internet-socket
)
272 address
&key
(reuse-address t
))
273 (declare (ignore address
))
275 (set-socket-option socket
:reuse-address
:value t
)))
277 (defun bind-ipv4-address (fd address port
)
278 (with-foreign-object (sin 'et
:sockaddr-in
)
279 (make-sockaddr-in sin address port
)
280 (with-socket-error-filter
281 (et:bind fd sin et
:size-of-sockaddr-in
))))
283 (defun bind-ipv6-address (fd address port
)
284 (with-foreign-object (sin6 'et
:sockaddr-in6
)
285 (make-sockaddr-in6 sin6 address port
)
286 (with-socket-error-filter
287 (et:bind fd sin6 et
:size-of-sockaddr-in6
))))
289 (defmethod bind-address ((socket internet-socket
)
292 (if (eql (socket-family socket
) :ipv6
)
293 (bind-ipv6-address (fd-of socket
)
294 (map-ipv4-vector-to-ipv6 (name address
))
296 (bind-ipv4-address (fd-of socket
) (name address
) port
))
299 (defmethod bind-address ((socket internet-socket
)
302 (bind-ipv6-address (fd-of socket
) (name address
) port
)
305 (defmethod bind-address :before
((socket local-socket
)
306 (address localaddr
) &key
)
307 (when (typep socket
'active-socket
)
308 (error "You can't bind an active Unix socket.")))
310 (defmethod bind-address ((socket local-socket
)
311 (address localaddr
) &key
)
312 (with-foreign-object (sun 'et
:sockaddr-un
)
313 (make-sockaddr-un sun
(name address
))
314 (with-socket-error-filter
315 (et:bind
(fd-of socket
) sun et
:size-of-sockaddr-un
)))
318 (defmethod bind-address :after
((socket socket
)
319 (address sockaddr
) &key
)
320 (setf (slot-value socket
'bound
) t
))
327 (defmethod socket-listen ((socket passive-socket
)
328 &key
(backlog (min *default-backlog-size
*
329 +max-backlog-size
+)))
330 (check-type backlog unsigned-byte
"a non-negative integer")
331 (with-socket-error-filter
332 (et:listen
(fd-of socket
) backlog
))
333 (setf (slot-value socket
'listening
) t
)
336 (defmethod socket-listen ((socket active-socket
)
338 (declare (ignore backlog
))
339 (error "You can't listen on active sockets."))
346 (defmethod accept-connection ((socket active-socket
)
348 (declare (ignore wait
))
349 (error "You can't accept connections on active sockets."))
351 (defmethod accept-connection ((socket passive-socket
)
353 (with-foreign-object (ss 'et
:sockaddr-storage
)
354 (et:bzero ss et
:size-of-sockaddr-storage
)
355 (with-foreign-pointer (size et
:size-of-socklen
)
356 (setf (mem-ref size
:socklen
)
357 et
:size-of-sockaddr-storage
)
358 (let (non-blocking-state
360 (with-socket-error-filter
363 ;; do a "normal" accept
364 ;; Note: the socket may already be in non-blocking mode
365 (setf client-fd
(et:accept
(fd-of socket
) ss size
))
366 ;; set the socket to non-blocking mode before calling accept()
367 ;; if there's no new connection return NIL
370 ;; saving the current non-blocking state
371 (setf non-blocking-state
(fd-non-blocking socket
))
372 ;; switch the socket to non-blocking mode
373 (setf (fd-non-blocking socket
) t
)
374 (setf client-fd
(et:accept
(fd-of socket
) ss size
)))
375 ;; restoring the socket's non-blocking state
376 (setf (fd-non-blocking socket
) non-blocking-state
)))
377 ;; the socket is marked non-blocking and there's no new connection
378 (et:ewouldblock
(err) (declare (ignore err
))
379 (return-from accept-connection nil
))))
382 ;; create the client socket object
383 (make-instance (active-class socket
)
384 :file-descriptor client-fd
)))
385 (return-from accept-connection client-socket
))))))
393 (defmethod connect :before
((socket active-socket
)
395 (declare (ignore sockaddr
))
397 (set-socket-option socket
:no-sigpipe
:value t
)))
399 (defun ipv4-connect (fd address port
)
400 (with-foreign-object (sin 'et
:sockaddr-in
)
401 (make-sockaddr-in sin address port
)
402 (with-socket-error-filter
403 (et:connect fd sin et
:size-of-sockaddr-in
))))
405 (defun ipv6-connect (fd address port
)
406 (with-foreign-object (sin6 'et
:sockaddr-in6
)
407 (make-sockaddr-in6 sin6 address port
)
408 (with-socket-error-filter
409 (et:connect fd sin6 et
:size-of-sockaddr-in6
))))
411 (defmethod connect ((socket internet-socket
)
412 (address ipv4addr
) &key
(port 0))
413 (if (eql (socket-family socket
) :ipv6
)
414 (ipv6-connect (fd-of socket
)
415 (map-ipv4-vector-to-ipv6 (name address
))
417 (ipv4-connect (fd-of socket
) (name address
) port
))
420 (defmethod connect ((socket internet-socket
)
421 (address ipv6addr
) &key
(port 0))
422 (ipv6-connect (fd-of socket
) (name address
) port
)
425 (defmethod connect ((socket local-socket
)
426 (address localaddr
) &key
)
427 (with-foreign-object (sun 'et
:sockaddr-un
)
428 (make-sockaddr-un sun
(name address
))
429 (with-socket-error-filter
430 (et:connect
(fd-of socket
) sun et
:size-of-sockaddr-un
)))
433 (defmethod connect ((socket passive-socket
)
435 (declare (ignore address
))
436 (error "You cannot connect passive sockets."))
438 (defmethod socket-connected-p ((socket socket
))
439 (unless (fd-of socket
)
440 (return-from socket-connected-p nil
))
441 (with-socket-error-filter
443 (with-foreign-object (ss 'et
:sockaddr-storage
)
444 (et:bzero ss et
:size-of-sockaddr-storage
)
445 (with-foreign-pointer (size et
:size-of-socklen
)
446 (setf (mem-ref size
:socklen
)
447 et
:size-of-sockaddr-storage
)
448 (et:getpeername
(fd-of socket
) ss size
)
450 (et:enotconn
(err) (declare (ignore err
))
458 (defmethod shutdown ((socket active-socket
) direction
)
459 (check-type direction
(member :read
:write
:read-write
)
460 "valid direction specifier")
461 (with-socket-error-filter
462 (et:shutdown
(fd-of socket
)
466 (:read-write et
:shut-rdwr
))))
469 (defmethod shutdown ((socket passive-socket
) direction
)
470 (declare (ignore direction
))
471 (error "You cannot shut down passive sockets."))
478 (defun %normalize-send-buffer
(buff start end ef
)
479 (setf (values start end
) (%check-bounds buff start end
))
481 (ub8-sarray (values buff start
(- end start
)))
482 (ub8-vector (values (coerce buff
'ub8-sarray
)
483 start
(- end start
)))
484 (string (values (%to-octets buff ef start end
)
487 (defmethod socket-send ((buffer array
)
488 (socket active-socket
) &key
(start 0) end
489 remote-address remote-port end-of-record
490 dont-route dont-wait
(no-signal *no-sigpipe
*)
491 out-of-band
#+linux more
#+linux confirm
)
492 (check-type start unsigned-byte
493 "a non-negative unsigned integer")
494 (check-type end
(or unsigned-byte null
)
495 "a non-negative unsigned integer or NIL")
496 (when (or remote-port remote-address
)
497 (check-type remote-address sockaddr
"a network address")
498 (check-type remote-port
(unsigned-byte 16) "a valid IP port number"))
499 (let ((flags (logior (if end-of-record et
:msg-eor
0)
500 (if dont-route et
:msg-dontroute
0)
501 (if dont-wait et
:msg-dontwait
0)
502 (if no-signal et
:msg-nosignal
0)
503 (if out-of-band et
:msg-oob
0)
504 #+linux
(if more et
:msg-more
0)
505 #+linux
(if confirm et
:msg-confirm
0))))
506 (when (and (ipv4-address-p remote-address
)
507 (eql (socket-family socket
) :ipv6
))
508 (setf remote-address
(map-ipv4-address->ipv6 remote-address
)))
509 (multiple-value-bind (buff start-offset bufflen
)
510 (%normalize-send-buffer buffer start end
(external-format-of socket
))
511 (with-foreign-object (ss 'et
:sockaddr-storage
)
512 (et:bzero ss et
:size-of-sockaddr-storage
)
514 (sockaddr->sockaddr-storage ss remote-address remote-port
))
515 (with-pointer-to-vector-data (buff-sap buff
)
516 (incf-pointer buff-sap start-offset
)
517 (with-socket-error-filter
518 (return-from socket-send
519 (et:sendto
(fd-of socket
)
522 (if remote-address ss
(null-pointer))
523 (if remote-address et
:size-of-sockaddr-storage
0)))))))))
525 (defmethod socket-send (buffer (socket passive-socket
) &key
)
526 (declare (ignore buffer
))
527 (error "You cannot send data on a passive socket."))
534 (defun %normalize-receive-buffer
(buff start end
)
535 (setf (values start end
) (%check-bounds buff start end
))
537 ((simple-array ub8
(*)) (values buff start
(- end start
)))))
539 (defmethod socket-receive ((buffer array
)
540 (socket active-socket
) &key
(start 0) end
541 out-of-band peek wait-all
542 dont-wait
(no-signal *no-sigpipe
*))
543 (let ((flags (logior (if out-of-band et
:msg-oob
0)
544 (if peek et
:msg-peek
0)
545 (if wait-all et
:msg-waitall
0)
546 (if dont-wait et
:msg-dontwait
0)
547 (if no-signal et
:msg-nosignal
0)))
549 (multiple-value-bind (buff start-offset bufflen
)
550 (%normalize-receive-buffer buffer start end
)
551 (with-foreign-object (ss 'et
:sockaddr-storage
)
552 (et:bzero ss et
:size-of-sockaddr-storage
)
553 (with-foreign-pointer (size et
:size-of-socklen
)
554 (setf (mem-ref size
:socklen
)
555 et
:size-of-sockaddr-storage
)
556 (with-pointer-to-vector-data (buff-sap buff
)
557 (incf-pointer buff-sap start-offset
)
558 (with-socket-error-filter
560 (et:recvfrom
(fd-of socket
)
565 (return-from socket-receive
566 ;; when socket is a datagram socket
567 ;; return the sender's address as 3rd value
568 (if (typep socket
'datagram-socket
)
569 (multiple-value-bind (remote-address remote-port
)
570 (sockaddr-storage->sockaddr ss
)
571 (values buffer bytes-received remote-address remote-port
))
572 (values buffer bytes-received
)))))))
574 (defmethod socket-receive (buffer (socket passive-socket
) &key
)
575 (declare (ignore buffer
))
576 (error "You cannot receive data from a passive socket."))
580 ;; Only for datagram sockets
583 (defmethod unconnect :before
((socket active-socket
))
584 (unless (typep socket
'datagram-socket
)
585 (error "You can only unconnect active datagram sockets.")))
587 (defmethod unconnect ((socket datagram-socket
))
588 (with-socket-error-filter
589 (with-foreign-object (sin 'et
:sockaddr-in
)
590 (et:bzero sin et
:size-of-sockaddr-in
)
591 (setf (foreign-slot-value sin
'et
:sockaddr-in
'et
:addr
) et
:af-unspec
)
592 (et:connect
(fd-of socket
) sin et
:size-of-sockaddr-in
))))