1 /* Part of Scheme 48 1.9. See file COPYING for notices and license.
2 *
3 * Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Marcus Crestani
4 */
5
6 #define NO_OLD_FFI 1
7
8 /*
9 * Unix-specific sockets stuff.
10 */
11
12 #include <sys/types.h>
13 #include <sys/socket.h>
14 #include <unistd.h>
15 #include <errno.h>
16 #include <fcntl.h>
17 #include <stdlib.h>
18 #ifdef HAVE_PTHREAD_H
19 #include <pthread.h>
20 #endif
21
22 #include <scheme48.h>
23
24 #include "c-mods.h"
25 #include "unix.h"
26 #include "fd-io.h" /* ps_close_fd() */
27 #include "event.h" /* add_pending_fd() */
28
29 #include "sysdep.h"
30
31 #include "socket.h"
32 #include "address.h"
33
34 static s48_ref_t
s48_socket(s48_call_t call,s48_ref_t sch_af,s48_ref_t sch_type,s48_ref_t sch_protocol)35 s48_socket(s48_call_t call, s48_ref_t sch_af, s48_ref_t sch_type, s48_ref_t sch_protocol)
36 {
37 socket_t fd;
38 int mode, status;
39 s48_ref_t sch_channel;
40 int af = s48_extract_af(call, sch_af);
41 int socktype = s48_extract_socket_type(call, sch_type);
42 int protocol = s48_extract_long_2(call, sch_protocol);
43
44 RETRY_OR_RAISE_NEG(fd, socket(af, socktype, protocol));
45 RETRY_OR_RAISE_NEG(status, fcntl(fd, F_SETFL, O_NONBLOCK));
46
47 sch_channel = s48_add_channel_2(call, s48_channel_status_special_input_2(call),
48 s48_enter_string_latin_1_2(call, "socket"), fd);
49
50 if (!s48_channel_p_2(call, sch_channel))
51 {
52 ps_close_fd(fd); /* retries if interrupted */
53 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, sch_channel), 0);
54 }
55
56 return sch_channel;
57 }
58
59 static s48_ref_t
s48_socketpair(s48_call_t call,s48_ref_t sch_af,s48_ref_t sch_type,s48_ref_t sch_protocol)60 s48_socketpair(s48_call_t call, s48_ref_t sch_af, s48_ref_t sch_type, s48_ref_t sch_protocol)
61 {
62 int status;
63 s48_ref_t sch_channel0, sch_channel1;
64 s48_ref_t sch_result;
65 int af = s48_extract_af(call, sch_af);
66 int socktype = s48_extract_socket_type(call, sch_type);
67 int protocol = s48_extract_long_2(call, sch_protocol);
68 socket_t fds[2];
69
70 RETRY_OR_RAISE_NEG(status, socketpair(af, socktype, protocol, fds));
71
72 RETRY_OR_RAISE_NEG(status, fcntl(fds[0], F_SETFL, O_NONBLOCK));
73 RETRY_OR_RAISE_NEG(status, fcntl(fds[1], F_SETFL, O_NONBLOCK));
74
75 sch_channel0 = s48_add_channel_2(call, s48_channel_status_input_2(call),
76 s48_enter_string_latin_1_2(call, "socket"), fds[0]);
77 sch_channel1 = s48_add_channel_2(call, s48_channel_status_input_2(call),
78 s48_enter_string_latin_1_2(call, "socket"), fds[1]);
79
80
81 sch_result = s48_cons_2(call, sch_channel0, sch_channel1);
82 return sch_result;
83 }
84
85 /*
86 * dup() `socket_fd' and return an output channel holding the result.
87 *
88 * We have to versions, one for calling from C and one for calling from Scheme.
89 */
90
91 static s48_ref_t
dup_socket_channel(s48_call_t call,socket_t socket_fd)92 dup_socket_channel(s48_call_t call, socket_t socket_fd)
93 {
94 socket_t output_fd;
95 s48_ref_t output_channel;
96 int flags;
97
98 RETRY_OR_RAISE_NEG(output_fd, dup(socket_fd));
99
100 RETRY_OR_RAISE_NEG(flags, fcntl(output_fd, F_GETFL));
101 flags |= O_NONBLOCK;
102 RETRY_OR_RAISE_NEG(flags, fcntl(output_fd, F_SETFL, flags));
103
104 output_channel = s48_add_channel_2(call, s48_channel_status_output_2(call),
105 s48_enter_string_latin_1_2(call, "socket connection"),
106 output_fd);
107
108 if (!s48_channel_p_2(call, output_channel))
109 {
110 ps_close_fd(output_fd); /* retries if interrupted */
111 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, output_channel), 0);
112 };
113
114 return output_channel;
115 }
116
117 socket_t
s48_extract_socket_fd(s48_call_t call,s48_ref_t sch_channel)118 s48_extract_socket_fd(s48_call_t call, s48_ref_t sch_channel)
119 {
120 s48_check_channel_2(call, sch_channel);
121 return s48_extract_long_2(call, s48_unsafe_channel_os_index_2(call, sch_channel));
122 }
123
124 static s48_ref_t
s48_dup_socket_channel(s48_call_t call,s48_ref_t sch_channel)125 s48_dup_socket_channel(s48_call_t call, s48_ref_t sch_channel)
126 {
127 return dup_socket_channel(call, s48_extract_socket_fd(call, sch_channel));
128 }
129
130 /*
131 * Given a bound socket, accept a connection and return a pair of the
132 * input channel and the raw socket address.
133 *
134 * If the accept fails because the client hasn't connected yet, then we
135 * return #f.
136 *
137 * If it fails for any other reason, then an exception is raised.
138 */
139
140 static s48_ref_t
s48_accept(s48_call_t call,s48_ref_t sch_channel,s48_ref_t sch_retry_p)141 s48_accept(s48_call_t call, s48_ref_t sch_channel, s48_ref_t sch_retry_p)
142 {
143 socket_t socket_fd = s48_extract_socket_fd(call, sch_channel);
144 socket_t connect_fd;
145 int status;
146 struct sockaddr_storage address;
147 socklen_t len;
148 s48_ref_t input_channel, output_channel;
149
150 len = sizeof(address);
151
152 connect_fd = accept(socket_fd, (struct sockaddr *)&address, &len);
153
154 if (connect_fd >= 0) {
155
156 RETRY_OR_RAISE_NEG(status, fcntl(connect_fd, F_SETFL, O_NONBLOCK));
157
158 input_channel = s48_add_channel_2(call, s48_channel_status_input_2(call),
159 s48_enter_string_latin_1_2(call, "socket connection"),
160 connect_fd);
161
162 if (!s48_channel_p_2(call, input_channel))
163 {
164 ps_close_fd(connect_fd); /* retries if interrupted */
165 s48_raise_scheme_exception_2(call, s48_extract_long_2(call, input_channel), 0);
166 }
167
168 return s48_cons_2(call,
169 input_channel,
170 s48_enter_sockaddr(call, (const struct sockaddr*)&address, len));
171 }
172
173 /*
174 * Check for errors. If we need to retry we mark the socket as pending
175 * and return #F to tell the Scheme procedure to wait.
176 */
177
178 if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno != EAGAIN))
179 s48_os_error_2(call, "s48_accept", errno, 2, sch_channel, sch_retry_p);
180
181 if (! s48_add_pending_fd(socket_fd, PSTRUE))
182 s48_out_of_memory_error_2(call);
183
184 return s48_false_2(call);
185 }
186
187 /*
188 * Given a socket and an address, connect the socket.
189 *
190 * If this succeeds, it returns an output channel for the connection.
191 * If it fails because the connect would block, add the socket to the
192 * pending queue (for output) and return #f.
193 * If it fails for any other reason, raise an exception.
194 */
195
196 static s48_ref_t
s48_connect(s48_call_t call,s48_ref_t sch_channel,s48_ref_t sch_address,s48_ref_t sch_retry_p)197 s48_connect(s48_call_t call, s48_ref_t sch_channel,
198 s48_ref_t sch_address, s48_ref_t sch_retry_p)
199 {
200 socket_t socket_fd = s48_extract_socket_fd(call, sch_channel);
201
202 /*
203 * Try the connection. If it works we make an output channel and return it.
204 * The original socket channel will be used as the input channel.
205 *
206 * FreeBSD's connect() behaves oddly. If you get told to wait, wait for
207 * select() to signal the all-clear, and then try to connect again, you
208 * get an `already connected' (EISCONN) error. To handle this we pass in
209 * a retry_p flag. If retry_p is true the `already connected' error is
210 * ignored.
211 */
212
213 if (connect(socket_fd,
214 s48_extract_value_pointer_2(call, sch_address, struct sockaddr),
215 s48_value_size_2(call, sch_address)) >= 0
216 || ((errno == EISCONN) && (s48_true_p_2(call, sch_retry_p))))
217 {
218 s48_unsafe_stob_set_2(call, sch_channel,
219 s48_channel_status_offset, s48_channel_status_input_2(call));
220 return dup_socket_channel(call, socket_fd);
221 }
222
223 /*
224 * Check for errors. If we need to retry we mark the socket as pending
225 * and return #F to tell the Scheme procedure to wait.
226 */
227
228 /* already connected, will raise an error from Scheme */
229 if (errno == EISCONN)
230 return s48_true_2(call);
231
232 if (errno != EWOULDBLOCK && errno != EINTR && errno != EALREADY
233 && errno != EINPROGRESS && errno != EAGAIN)
234 s48_os_error_2(call, "s48_connect", errno, 3, sch_channel, sch_address, sch_retry_p);
235
236 if (! (s48_add_pending_fd(socket_fd, PSFALSE)))
237 s48_out_of_memory_error_2(call);
238
239 return s48_false_2(call);
240 }
241
242 /*
243 * Receive a message. Returns pair (<byte-count> . <sender>) or just
244 * <byte-count> if want_sender_p is false.
245 */
246
247 static s48_ref_t
s48_recvfrom(s48_call_t call,s48_ref_t sch_channel,s48_ref_t sch_buffer,s48_ref_t sch_start,s48_ref_t sch_count,s48_ref_t sch_flags,s48_ref_t sch_want_sender_p,s48_ref_t sch_retry_p)248 s48_recvfrom(s48_call_t call, s48_ref_t sch_channel,
249 s48_ref_t sch_buffer, s48_ref_t sch_start, s48_ref_t sch_count,
250 s48_ref_t sch_flags,
251 s48_ref_t sch_want_sender_p,
252 s48_ref_t sch_retry_p)
253 {
254 socket_t socket_fd = s48_extract_socket_fd(call, sch_channel);
255 int want_sender_p = !(s48_false_p_2(call, sch_want_sender_p));
256 struct sockaddr_storage from;
257 socklen_t from_len = (want_sender_p ? sizeof(struct sockaddr_storage) : 0);
258 int flags = s48_extract_msg_flags(call, sch_flags);
259 size_t buffer_size = s48_byte_vector_length_2(call, sch_buffer);
260 size_t start = s48_extract_unsigned_long_2(call, sch_start);
261 size_t count = s48_extract_unsigned_long_2(call, sch_count);
262 ssize_t status;
263
264 if ((start + count) > buffer_size)
265 s48_assertion_violation_2(call, "s48_sendto", "buffer start or count is wrong", 3,
266 sch_buffer, sch_start, sch_count);
267
268 status = recvfrom(socket_fd,
269 s48_extract_byte_vector_2(call, sch_buffer) + start,
270 count,
271 flags,
272 want_sender_p ? (struct sockaddr*)&from : NULL,
273 &from_len);
274
275 if (0 <= status)
276 {
277 if (want_sender_p)
278 {
279 s48_ref_t sch_count, sch_saddr;
280 s48_ref_t sch_result;
281 sch_count = s48_enter_unsigned_long_2(call, status);
282 sch_saddr = s48_enter_sockaddr(call, (struct sockaddr *)&from, from_len);
283 sch_result = s48_cons_2(call, sch_count, sch_saddr);
284 return sch_result;
285 }
286 else
287 return s48_enter_unsigned_long_2(call, status);
288 }
289
290 /*
291 * Check for errors. If we need to retry we mark the socket as pending
292 * and return #F to tell the Scheme procedure to wait.
293 */
294
295 if (errno != EWOULDBLOCK && errno != EINTR && errno != EALREADY
296 && errno != EINPROGRESS && errno != EAGAIN)
297 s48_os_error_2(call, "s48_recv", errno, 6,
298 sch_channel, sch_buffer, sch_start, sch_count,
299 sch_flags, sch_want_sender_p);
300
301 if (! (s48_add_pending_fd(socket_fd, PSTRUE)))
302 s48_out_of_memory_error_2(call);
303
304 return s48_false_2(call);
305 }
306
307 static s48_ref_t
s48_sendto(s48_call_t call,s48_ref_t sch_channel,s48_ref_t sch_buffer,s48_ref_t sch_start,s48_ref_t sch_count,s48_ref_t sch_flags,s48_ref_t sch_saddr,s48_ref_t sch_retry_p)308 s48_sendto(s48_call_t call, s48_ref_t sch_channel,
309 s48_ref_t sch_buffer, s48_ref_t sch_start, s48_ref_t sch_count,
310 s48_ref_t sch_flags,
311 s48_ref_t sch_saddr,
312 s48_ref_t sch_retry_p) /* ignored on Unix */
313 {
314 socket_t socket_fd = s48_extract_socket_fd(call, sch_channel);
315 ssize_t sent;
316 const struct sockaddr *sa
317 = s48_extract_value_pointer_2(call, sch_saddr, const struct sockaddr);
318 socklen_t salen = s48_value_size_2(call, sch_saddr);
319 int flags = s48_extract_msg_flags(call, sch_flags);
320 size_t buffer_size = s48_byte_vector_length_2(call, sch_buffer);
321 size_t start = s48_extract_unsigned_long_2(call, sch_start);
322 size_t count = s48_extract_unsigned_long_2(call, sch_count);
323
324 if ((start + count) > buffer_size)
325 s48_assertion_violation_2(call, "s48_sendto", "buffer start or count is wrong", 3,
326 sch_buffer, sch_start, sch_count);
327
328 sent = sendto(socket_fd,
329 s48_extract_byte_vector_readonly_2(call, sch_buffer) + start,
330 count,
331 flags,
332 (struct sockaddr *) sa, salen);
333
334 if (0 <= sent)
335 return s48_enter_unsigned_long_2(call, sent);
336
337 /*
338 * Check for errors. If we need to retry we mark the socket as pending
339 * and return #F to tell the Scheme procedure to wait.
340 */
341
342 if (errno != EWOULDBLOCK && errno != EINTR && errno != EALREADY
343 && errno != EINPROGRESS && errno != EAGAIN)
344 s48_os_error_2(call, "s48_sendto", errno, 6,
345 sch_channel, sch_saddr, sch_flags, sch_buffer, sch_start, sch_count);
346
347 if (! (s48_add_pending_fd(socket_fd, PSFALSE)))
348 s48_out_of_memory_error_2(call);
349
350 return s48_false_2(call);
351 }
352
353 void
s48_init_os_sockets(void)354 s48_init_os_sockets(void)
355 {
356 S48_EXPORT_FUNCTION(s48_socket);
357 S48_EXPORT_FUNCTION(s48_socketpair);
358 S48_EXPORT_FUNCTION(s48_dup_socket_channel);
359 S48_EXPORT_FUNCTION(s48_accept);
360 S48_EXPORT_FUNCTION(s48_connect);
361 S48_EXPORT_FUNCTION(s48_recvfrom);
362 S48_EXPORT_FUNCTION(s48_sendto);
363 }
364