1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; make-socket.lisp --- Socket creation.
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 ;;; FIXME: protocol is sort of misinterpreted.
28 ;;; CREATE-SOCKET is a a bit of a confusing name as it is too similar
29 ;;; to MAKE-SOCKET. I thought about different names and considered
30 ;;; the option of moving this "factory" code could be moved into
31 ;;; MAKE-INSTANCE methods. However, AFAICT, MAKE-SOCKET can achieve
32 ;;; the exact same effect as CREATE-SOCKET when some of the parameters
33 ;;; are ommitted so I have opted to remove CREATE-SOCKET from the
34 ;;; export list. --luis
35 (defun create-socket (&key
(family :internet
) (type :stream
) (connect :active
)
36 (protocol :default
) (ipv6 *ipv6
*)
37 (external-format :default
))
38 (when (or (null family
) (eq family
:internet
))
39 (setf family
(if ipv6
:ipv6
:ipv4
)))
40 (let ((class (select-socket-type family type connect protocol
)))
43 :external-format external-format
)))
45 (defmacro %with-close-on-error
((var value
) &body body
)
46 (with-unique-names (errorp)
47 `(let ((,var
,value
) (,errorp t
))
48 (unwind-protect (prog1 (locally ,@body
,var
) (setf ,errorp nil
))
49 (when (and ,var
,errorp
) (close ,var
:abort t
))))))
51 (defun convert-or-lookup-inet-address (address &optional
(ipv6 *ipv6
*))
52 "If ADDRESS is an inet-address designator, it is converted, if
53 necessary, to an INET-ADDRESS object and returned. Otherwise it
54 is assumed to be a host name which is then looked up in order to
55 return its primary address as the first return value and the
56 remaining address list as the second return value."
57 (or (ignore-parse-errors (ensure-address address
:internet
))
58 (let ((addresses (lookup-host address
:ipv6 ipv6
)))
59 (values (car addresses
) (cdr addresses
)))))
61 (declaim (inline %make-internet-stream-socket
))
62 (defun %make-internet-stream-socket
(args connect ef
)
63 (destructuring-bind (&key family local-host
(local-port 0) remote-host
(remote-port 0)
64 (backlog *default-backlog-size
*) reuse-address keepalive nodelay
)
68 (%with-close-on-error
(socket (create-socket :family family
:type
:stream
69 :connect
:active
:external-format ef
))
70 (when keepalive
(set-socket-option socket
:keep-alive
:value t
))
71 (when nodelay
(set-socket-option socket
:tcp-nodelay
:value t
))
73 (bind-address socket
(convert-or-lookup-inet-address local-host
)
75 :reuse-address reuse-address
))
77 (connect socket
(convert-or-lookup-inet-address remote-host
)
80 (%with-close-on-error
(socket (create-socket :family family
:type
:stream
81 :connect
:passive
:external-format ef
))
83 (bind-address socket
(convert-or-lookup-inet-address local-host
)
85 :reuse-address reuse-address
)
86 (socket-listen socket
:backlog backlog
)))))))
88 (declaim (inline %make-local-stream-socket
))
89 (defun %make-local-stream-socket
(args connect ef
)
90 (destructuring-bind (&key family local-filename remote-filename
(backlog *default-backlog-size
*))
94 (assert remote-filename
)
95 (%with-close-on-error
(socket (create-socket :family family
:type
:stream
96 :connect
:active
:external-format ef
))
98 (bind-address socket
(make-address local-filename
)))
99 (connect socket
(make-address remote-filename
))))
101 (assert local-filename
)
102 (%with-close-on-error
(socket (create-socket :family family
:type
:stream
103 :connect
:passive
:external-format ef
))
104 (bind-address socket
(make-address local-filename
))
105 (socket-listen socket
:backlog backlog
))))))
107 (declaim (inline %make-internet-datagram-socket
))
108 (defun %make-internet-datagram-socket
(args ef
)
109 (destructuring-bind (&key family local-host
(local-port 0) remote-host
110 (remote-port 0) reuse-address broadcast
)
112 (%with-close-on-error
(socket (create-socket :family family
:type
:datagram
113 :connect
:active
:external-format ef
))
114 (when broadcast
(set-socket-option socket
:broadcast
:value t
))
116 (bind-address socket
(convert-or-lookup-inet-address local-host
)
118 :reuse-address reuse-address
))
120 (connect socket
(convert-or-lookup-inet-address remote-host
)
121 :port remote-port
)))))
123 (declaim (inline %make-local-datagram-socket
))
124 (defun %make-local-datagram-socket
(args ef
)
125 (destructuring-bind (&key family local-filename remote-filename
) args
126 (%with-close-on-error
(socket (create-socket :family family
:type
:datagram
127 :connect
:active
:external-format ef
))
129 (bind-address socket
(ensure-address local-filename
:local
)))
130 (when remote-filename
131 (connect socket
(ensure-address remote-filename
:local
))))))
133 ;;; Changed ADDRESS-FAMILY to FAMILY and accept :IPV4 and :IPV6 as
134 ;;; arguments so we can create an IPv4 socket with
135 ;;; (make-socket :family :ipv4)
137 ;;; (make-socket #|:family :internet|# :ipv6 nil)
138 ;;; This is not compatible with Allegro's MAKE-SOCKET behaviour.
139 ;;; Is the renaming and the acceptance of extra values a problem?
140 ;;; (We need to be careful with *IPV6* for starters.)
141 (defun make-socket (&rest args
&key
(family :internet
) (type :stream
)
142 (connect :active
) (ipv6 *ipv6
*) format eol
143 (external-format :default
) scope-id
&allow-other-keys
)
144 "Creates a socket instance of the appropriate subclass of SOCKET."
145 (declare (ignore format eol scope-id
))
146 (check-type family
(member :internet
:local
:ipv4
:ipv6
))
147 (check-type type
(member :stream
:datagram
))
148 (check-type connect
(member :active
:passive
))
150 (remf args
:external-format
)
153 (let ((*ipv6
* (if (eq family
:ipv4
) nil ipv6
))
154 (address-family (if (or (eq family
:ipv4
) (eq family
:ipv6
))
158 ((and (eq address-family
:internet
) (eq type
:stream
))
159 (%make-internet-stream-socket args connect external-format
))
160 ((and (eq address-family
:local
) (eq type
:stream
))
161 (%make-local-stream-socket args connect external-format
))
162 ((and (eq address-family
:internet
) (eq type
:datagram
))
163 (%make-internet-datagram-socket args external-format
))
164 ((and (eq address-family
:local
) (eq type
:datagram
))
165 (%make-local-datagram-socket args external-format
)))))
167 (defmacro with-open-socket
((var &rest args
) &body body
)
168 "VAR is bound to a socket created by passing ARGS to
169 MAKE-SOCKET and BODY is executed as implicit PROGN. The socket
170 is automatically closed upon exit."
171 `(with-open-stream (,var
(make-socket ,@args
)) ,@body
))
173 (defmacro with-accept-connection
((var passive-socket
&rest args
) &body body
)
174 "VAR is bound to a socket created by passing PASSIVE-SOCKET and ARGS to
175 ACCEPT-CONNECTION and BODY is executed as implicit PROGN. The socket
176 is automatically closed upon exit."
177 `(with-open-stream (,var
(accept-connection ,passive-socket
,@args
)) ,@body
))