~ chicken-core (chicken-5) /tcp.scm

  1;;;; tcp.scm - Networking stuff
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  8; conditions are met:
  9;
 10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 11;     disclaimer. 
 12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 13;     disclaimer in the documentation and/or other materials provided with the distribution. 
 14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 15;     products derived from this software without specific prior written permission. 
 16;
 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 25; POSSIBILITY OF SUCH DAMAGE.
 26
 27
 28(declare
 29  (unit tcp)
 30  (uses port scheduler)
 31  (disable-interrupts) ; Avoid race conditions around errno/WSAGetLastError
 32  (foreign-declare #<<EOF
 33#ifdef _WIN32
 34# include <winsock2.h>
 35# include <ws2tcpip.h>
 36/* Beware: winsock2.h must come BEFORE windows.h */
 37# define socklen_t	 int
 38static WSADATA wsa;
 39# ifndef SHUT_RD
 40#  define SHUT_RD	  SD_RECEIVE
 41# endif
 42# ifndef SHUT_WR
 43#  define SHUT_WR	  SD_SEND
 44# endif
 45
 46# define typecorrect_getsockopt(socket, level, optname, optval, optlen)	\
 47    getsockopt(socket, level, optname, (char *)optval, optlen)
 48
 49static C_word make_socket_nonblocking (C_word sock) {
 50  int fd = C_unfix(sock);
 51  C_return(C_mk_bool(ioctlsocket(fd, FIONBIO, (void *)&fd) != SOCKET_ERROR)) ;
 52}
 53
 54/* This is a bit of a hack, but it keeps things simple */
 55static C_TLS char *last_wsa_errorstring = NULL;
 56
 57static char *errormsg_from_code(int code) {
 58  int bufsize;
 59  if (last_wsa_errorstring != NULL) {
 60    LocalFree(last_wsa_errorstring);
 61    last_wsa_errorstring = NULL;
 62  }
 63  bufsize = FormatMessage(
 64	FORMAT_MESSAGE_ALLOCATE_BUFFER |
 65	FORMAT_MESSAGE_FROM_SYSTEM |
 66	FORMAT_MESSAGE_IGNORE_INSERTS,
 67	NULL, code, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
 68	(LPTSTR) &last_wsa_errorstring, 0, NULL);
 69  if (bufsize == 0) return "ERROR WHILE FETCHING ERROR";
 70  return last_wsa_errorstring;
 71}
 72
 73# define get_last_socket_error()  WSAGetLastError()
 74# define should_retry_call()      (WSAGetLastError() == WSAEWOULDBLOCK)
 75/* Not EINPROGRESS in winsock.  Nonblocking connect returns EWOULDBLOCK... */
 76# define call_in_progress()       (WSAGetLastError() == WSAEWOULDBLOCK)
 77# define call_was_interrupted()   (WSAGetLastError() == WSAEINTR) /* ? */
 78
 79#else
 80# include <errno.h>
 81# include <fcntl.h>
 82# include <sys/socket.h>
 83# include <sys/time.h>
 84# include <netinet/in.h>
 85# include <netdb.h>
 86# include <signal.h>
 87# define closesocket     close
 88# define INVALID_SOCKET  -1
 89# define SOCKET_ERROR    -1
 90# define typecorrect_getsockopt getsockopt
 91
 92static C_word make_socket_nonblocking (C_word sock) {
 93  int fd = C_unfix(sock);
 94  int val = fcntl(fd, F_GETFL, 0);
 95  if(val == -1) C_return(C_SCHEME_FALSE);
 96  C_return(C_mk_bool(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1));
 97}
 98
 99# define get_last_socket_error()  errno
100# define errormsg_from_code(e)    strerror(e)
101
102# define should_retry_call()      (errno == EAGAIN || errno == EWOULDBLOCK)
103# define call_was_interrupted()   (errno == EINTR)
104# define call_in_progress()       (errno == EINPROGRESS)
105#endif
106
107#ifdef ECOS
108#include <sys/sockio.h>
109#endif
110
111#ifndef h_addr
112# define h_addr  h_addr_list[ 0 ]
113#endif
114
115static char addr_buffer[ 20 ];
116
117static int C_set_socket_options(int socket)
118{
119  int yes = 1; 
120  int r;
121
122  r = setsockopt(socket, SOL_SOCKET, SO_REUSEADDR, (const char *)&yes, sizeof(int));
123  
124  if(r != 0) return r;
125
126#ifdef SO_NOSIGPIPE
127  /*
128   * Avoid SIGPIPE (iOS uses *only* SIGPIPE otherwise, not returning EPIPE).
129   * For consistency we do this everywhere the option is supported.
130   */
131  r = setsockopt(socket, SOL_SOCKET, SO_NOSIGPIPE, (const char *)&yes, sizeof(int));
132#endif
133
134  return r;
135}
136
137EOF
138) )
139
140(module chicken.tcp
141  (tcp-close tcp-listen tcp-connect tcp-accept tcp-accept-ready?
142   tcp-listener? tcp-addresses tcp-abandon-port tcp-listener-port
143   tcp-listener-fileno tcp-port-numbers tcp-buffer-size tcp-read-timeout
144   tcp-write-timeout tcp-accept-timeout tcp-connect-timeout)
145
146(import scheme
147	chicken.base
148	chicken.fixnum
149	chicken.foreign
150	chicken.port
151	chicken.time)
152
153(include "common-declarations.scm")
154
155
156(define-foreign-type sockaddr* (pointer "struct sockaddr"))
157(define-foreign-type sockaddr_in* (pointer "struct sockaddr_in"))
158
159(define-foreign-variable _af_inet int "AF_INET")
160(define-foreign-variable _sock_stream int "SOCK_STREAM")
161(define-foreign-variable _sock_dgram int "SOCK_DGRAM")
162(define-foreign-variable _sockaddr_size int "sizeof(struct sockaddr)")
163(define-foreign-variable _sockaddr_in_size int "sizeof(struct sockaddr_in)")
164(define-foreign-variable _shut_rd int "SHUT_RD")
165(define-foreign-variable _shut_wr int "SHUT_WR")
166(define-foreign-variable _ipproto_tcp int "IPPROTO_TCP")
167(define-foreign-variable _invalid_socket int "INVALID_SOCKET")
168(define-foreign-variable _socket_error int "SOCKET_ERROR")
169
170(define last-error-code (foreign-lambda int "get_last_socket_error"))
171(define error-code->message (foreign-lambda c-string "errormsg_from_code" int))
172(define retry? (foreign-lambda bool "should_retry_call"))
173(define in-progress? (foreign-lambda bool "call_in_progress"))
174(define interrupted? (foreign-lambda bool "call_was_interrupted"))
175(define socket (foreign-lambda int "socket" int int int))
176(define bind (foreign-lambda int "bind" int scheme-pointer int))
177(define listen (foreign-lambda int "listen" int int))
178(define accept (foreign-lambda int "accept" int c-pointer c-pointer))
179(define close (foreign-lambda int "closesocket" int))
180(define recv (foreign-lambda int "recv" int scheme-pointer int int))
181(define shutdown (foreign-lambda int "shutdown" int int))
182(define connect (foreign-lambda int "connect" int scheme-pointer int))
183(define check-fd-ready (foreign-lambda int "C_check_fd_ready" int))
184(define set-socket-options (foreign-lambda int "C_set_socket_options" int))
185
186(define send
187  (foreign-lambda* 
188      int ((int s) (scheme-pointer msg) (int offset) (int len) (int flags))
189    "C_return(send(s, (char *)msg+offset, len, flags));"))
190
191(define getsockname
192  (foreign-lambda* c-string ((int s))
193    "struct sockaddr_in sa;"
194    "unsigned char *ptr;"
195    "int len = sizeof(struct sockaddr_in);"
196    "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)&len) != 0) C_return(NULL);"
197    "ptr = (unsigned char *)&sa.sin_addr;"
198    "C_snprintf(addr_buffer, sizeof(addr_buffer), \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
199    "C_return(addr_buffer);") )
200
201(define getsockport
202  (foreign-lambda* int ((int s))
203    "struct sockaddr_in sa;"
204    "int len = sizeof(struct sockaddr_in);"
205    "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) C_return(-1);"
206    "else C_return(ntohs(sa.sin_port));") )
207
208(define getpeerport
209 (foreign-lambda* int ((int s))
210   "struct sockaddr_in sa;"
211   "int len = sizeof(struct sockaddr_in);"
212   "if(getpeername(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) C_return(-1);"
213   "else C_return(ntohs(sa.sin_port));") )
214
215(define getpeername
216  (foreign-lambda* c-string ((int s))
217    "struct sockaddr_in sa;"
218    "unsigned char *ptr;"
219    "unsigned int len = sizeof(struct sockaddr_in);"
220    "if(getpeername(s, (struct sockaddr *)&sa, ((socklen_t *)&len)) != 0) C_return(NULL);"
221    "ptr = (unsigned char *)&sa.sin_addr;"
222    "C_snprintf(addr_buffer, sizeof(addr_buffer), \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
223    "C_return(addr_buffer);") )
224
225(define startup
226  (foreign-lambda* bool () #<<EOF
227#ifdef _WIN32
228     C_return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);
229#else
230     signal(SIGPIPE, SIG_IGN);
231     C_return(1);
232#endif
233EOF
234) )
235
236(unless (startup)
237  (##sys#signal-hook #:network-error "cannot initialize Winsock") )
238
239(define getservbyname
240  (foreign-lambda* int ((c-string serv) (c-string proto))
241    "struct servent *se;
242     if((se = getservbyname(serv, proto)) == NULL) C_return(0);
243     else C_return(ntohs(se->s_port));") )     
244
245(define gethostaddr
246  (foreign-lambda* bool ((nonnull-scheme-pointer saddr) (c-string host) (unsigned-short port))
247    "struct hostent *he = gethostbyname(host);"
248    "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
249    "if(he == NULL) C_return(0);"
250    "memset(addr, 0, sizeof(struct sockaddr_in));"
251    "addr->sin_family = AF_INET;"
252    "addr->sin_port = htons((short)port);"
253    "addr->sin_addr = *((struct in_addr *)he->h_addr);"
254    "C_return(1);") )
255
256(define-syntax network-error
257  (syntax-rules ()
258    ((_ loc msg . args)
259     (network-error/code loc (last-error-code) msg . args))))
260
261(define-syntax network-error/close
262  (syntax-rules ()
263    ((_ loc msg socket . args)
264     (let ((error-code (last-error-code)))
265       (close socket)
266       (network-error/code loc error-code msg socket . args)))))
267
268(define-syntax network-error/code
269  (syntax-rules ()
270    ((_ loc error-code msg . args)
271     (##sys#signal-hook #:network-error loc
272			(string-append (string-append msg " - ")
273				       (error-code->message error-code))
274			. args))))
275
276(define parse-host
277  (let ((substring substring))
278    (lambda (host proto)
279      (let ((len (##sys#size host)))
280	(let loop ((i 0))
281	  (if (fx>= i len)
282	      (values host #f)
283	      (let ((c (##core#inline "C_subchar" host i)))
284		(if (char=? c #\:)		    
285		    (values
286		     (substring host (fx+ i 1) len)
287		     (let* ((s (substring host 0 i))
288			    (p (getservbyname s proto)))
289		       (when (eq? 0 p)
290			 (network-error 'tcp-connect "cannot compute port from service" s) )
291		       p) )
292		    (loop (fx+ i 1)) ) ) ) ) ) ) ) )
293
294(define fresh-addr
295  (foreign-lambda* void ((nonnull-scheme-pointer saddr) (unsigned-short port))
296    "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
297    "memset(addr, 0, sizeof(struct sockaddr_in));"
298    "addr->sin_family = AF_INET;"
299    "addr->sin_port = htons(port);"
300    "addr->sin_addr.s_addr = htonl(INADDR_ANY);") )
301
302(define (bind-socket style host port)
303  (let ((addr (make-string _sockaddr_in_size)))
304    (if host
305	(unless (gethostaddr addr host port)
306	  (##sys#signal-hook 
307	   #:network-error 'tcp-listen 
308	   "getting listener host IP failed" host port) )
309	(fresh-addr addr port) )
310    (let ((s (socket _af_inet style 0)))
311      (when (eq? _invalid_socket s)
312	(##sys#error "cannot create socket") )
313      ;; PLT makes this an optional arg to tcp-listen. Should we as well?
314      (when (eq? _socket_error (set-socket-options s))
315	(network-error 'tcp-listen "error while setting up socket" s) )
316      (when (eq? _socket_error (bind s addr _sockaddr_in_size))
317	(network-error/close 'tcp-listen "cannot bind to socket" s host port) )
318      s)) )
319
320(define-constant default-backlog 100)
321
322(define (tcp-listen port #!optional (backlog default-backlog) host)
323  (##sys#check-fixnum port)
324  (when (or (fx< port 0) (fx> port 65535))
325    (##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) )
326  (##sys#check-fixnum backlog)
327  (let ((s (bind-socket _sock_stream host port)))
328    (when (eq? _socket_error (listen s backlog))
329      (network-error/close 'tcp-listen "cannot listen on socket" s port) )
330    (##sys#make-structure 'tcp-listener s) ) )
331
332(define (tcp-listener? x) 
333  (and (##core#inline "C_blockp" x)
334       (##sys#structure? x 'tcp-listener) ) )
335
336(define (tcp-close tcpl)
337  (##sys#check-structure tcpl 'tcp-listener)
338  (let ((s (##sys#slot tcpl 1)))
339    (when (eq? _socket_error (close s))
340      (network-error 'tcp-close "cannot close TCP socket" tcpl) ) ) )
341
342(define-constant +input-buffer-size+ 1024)
343(define-constant +output-chunk-size+ 8192)
344
345(define tcp-buffer-size (make-parameter #f))
346(define tcp-read-timeout)
347(define tcp-write-timeout)
348(define tcp-connect-timeout)
349(define tcp-accept-timeout)
350
351(let ()
352  (define ((check loc) x)
353    (when x (##sys#check-fixnum x loc))
354    x)
355  (define minute (fx* 60 1000))
356  (set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout)))
357  (set! tcp-write-timeout (make-parameter minute (check 'tcp-write-timeout))) 
358  (set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout))) 
359  (set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )
360
361(define io-ports
362  (let ((tbs tcp-buffer-size))
363    (lambda (loc fd)
364      (unless (##core#inline "make_socket_nonblocking" fd)
365	(network-error/close loc "cannot create TCP ports" fd) )
366      (let* ((buf (make-string +input-buffer-size+))
367	     (data (vector fd #f #f buf 0))
368	     (buflen 0)
369	     (bufindex 0)
370	     (iclosed #f) 
371	     (oclosed #f)
372	     (outbufsize (tbs))
373	     (outbuf (and outbufsize (fx> outbufsize 0) ""))
374	     (read-input
375	      (lambda ()
376		(let* ((tmr (tcp-read-timeout))
377		       (dlr (and tmr (+ (current-process-milliseconds) tmr))))
378		  (let loop ()
379		    (let ((n (recv fd buf +input-buffer-size+ 0)))
380		      (cond ((eq? _socket_error n)
381			     (cond ((retry?)
382				    (when dlr
383				      (##sys#thread-block-for-timeout!
384				       ##sys#current-thread dlr) )
385				    (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
386				    (##sys#thread-yield!)
387				    (when (##sys#slot ##sys#current-thread 13)
388				      (##sys#signal-hook
389				       #:network-timeout-error
390				       "read operation timed out" tmr fd) )
391				    (loop) )
392				   ((interrupted?)
393				    (##sys#dispatch-interrupt loop))
394				   (else
395				    (network-error #f "cannot read from socket" fd) ) ) )
396			    (else
397			     (set! buflen n)
398			     (##sys#setislot data 4 n)
399			     (set! bufindex 0) ) ) ) )) ) )
400	     (in
401	      (make-input-port
402	       (lambda ()
403		 (when (fx>= bufindex buflen)
404		   (read-input))
405		 (if (fx>= bufindex buflen)
406		     #!eof
407		     (let ((c (##core#inline "C_subchar" buf bufindex)))
408		       (set! bufindex (fx+ bufindex 1))
409		       c) ) )
410	       (lambda ()
411		 (or (fx< bufindex buflen)
412		     ;; XXX: This "knows" that check_fd_ready is
413		     ;; implemented using a winsock2 call on Windows
414		     (let ((f (check-fd-ready fd)))
415		       (when (eq? _socket_error f)
416			 (network-error #f "cannot check socket for input" fd) )
417		       (eq? f 1) ) ) )
418	       (lambda ()
419		 (unless iclosed
420		   (set! iclosed #t)
421		   (unless (##sys#slot data 1) (shutdown fd _shut_rd))
422		   (when (and oclosed (eq? _socket_error (close fd)))
423		     (network-error #f "cannot close socket input port" fd) ) ) )
424	       (lambda ()
425		 (when (fx>= bufindex buflen)
426		   (read-input))
427		 (if (fx< bufindex buflen)
428		     (##core#inline "C_subchar" buf bufindex)
429		     #!eof))
430	       (lambda (p n dest start)	; read-string!
431		 (let loop ((n n) (m 0) (start start))
432		   (cond ((eq? n 0) m)
433			 ((fx< bufindex buflen)
434			  (let* ((rest (fx- buflen bufindex))
435				 (n2 (if (fx< n rest) n rest)))
436			    (##core#inline "C_substring_copy" buf dest bufindex (fx+ bufindex n2) start)
437			    (set! bufindex (fx+ bufindex n2))
438			    (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )
439			 (else
440			  (read-input)
441			  (if (eq? buflen 0) 
442			      m
443			      (loop n m start) ) ) ) ) )
444	       (lambda (p limit)	; read-line
445		 (when (fx>= bufindex buflen)
446		   (read-input))
447		 (if (fx>= bufindex buflen)
448		     #!eof
449		     (let ((limit (or limit (fx- most-positive-fixnum bufindex))))
450		       (receive (next line full-line?)
451			   (##sys#scan-buffer-line
452			    buf
453			    (fxmin buflen (fx+ bufindex limit))
454			    bufindex
455			    (lambda (pos)
456			      (let ((nbytes (fx- pos bufindex)))
457				(cond ((fx>= nbytes limit)
458				       (values #f pos #f))
459				      (else (read-input)
460					    (set! limit (fx- limit nbytes))
461					    (if (fx< bufindex buflen)
462						(values buf bufindex
463							(fxmin buflen
464							       (fx+ bufindex limit)))
465						(values #f bufindex #f))))) ) )
466			 ;; Update row & column position
467			 (if full-line?
468			     (begin
469			       (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
470			       (##sys#setislot p 5 0))
471			     (##sys#setislot p 5 (fx+ (##sys#slot p 5)
472						      (##sys#size line))))
473			 (set! bufindex next)
474			 line) )) )
475	       (lambda (p)		; read-buffered
476		 (if (fx>= bufindex buflen)
477		     ""
478		     (let ((str (##sys#substring buf bufindex buflen)))
479		       (set! bufindex buflen)
480		       str)))
481	       ) )
482	     (output
483	      (lambda (s)
484		(let ((tmw (tcp-write-timeout)))
485		  (let loop ((len (##sys#size s))
486			     (offset 0)
487			     (dlw (and tmw (+ (current-process-milliseconds) tmw))))
488		    (let* ((count (fxmin +output-chunk-size+ len))
489			   (n (send fd s offset count 0)))
490		      (cond ((eq? _socket_error n)
491			     (cond ((retry?)
492				    (when dlw
493				      (##sys#thread-block-for-timeout!
494				       ##sys#current-thread dlw) )
495				    (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
496				    (##sys#thread-yield!)
497				    (when (##sys#slot ##sys#current-thread 13)
498				      (##sys#signal-hook
499				       #:network-timeout-error
500				       "write operation timed out" tmw fd) )
501				    (loop len offset dlw) )
502				   ((interrupted?)
503				    (##sys#dispatch-interrupt
504				     (cut loop len offset dlw)))
505				   (else
506				    (network-error #f "cannot write to socket" fd) ) ) )
507			    ((fx< n len)
508			     (loop (fx- len n) (fx+ offset n)
509				   (if (fx= n 0)
510				       tmw
511				       ;; If we wrote *something*, reset timeout
512				       (and tmw (+ (current-process-milliseconds) tmw)) )) ) ) ) )) ) )
513	     (out
514	      (make-output-port
515	       (if outbuf
516		   (lambda (s)
517		     (set! outbuf (##sys#string-append outbuf s))
518		     (when (fx>= (##sys#size outbuf) outbufsize)
519		       (output outbuf)
520		       (set! outbuf "") ) )
521		   (lambda (s) 
522		     (when (fx> (##sys#size s) 0)
523		       (output s)) ) )
524	       (lambda ()
525		 (unless oclosed
526		   (set! oclosed #t)
527		   (when (and outbuf (fx> (##sys#size outbuf) 0))
528		     (output outbuf)
529		     (set! outbuf "") )
530		   (unless (##sys#slot data 2) (shutdown fd _shut_wr))
531		   (when (and iclosed (eq? _socket_error (close fd)))
532		     (network-error #f "cannot close socket output port" fd) ) ) )
533	       (and outbuf
534		    (lambda ()
535		      (when (fx> (##sys#size outbuf) 0)
536			(output outbuf)
537			(set! outbuf "") ) ) ) ) ) )
538	(##sys#setslot in 3 "(tcp)")
539	(##sys#setslot out 3 "(tcp)")
540	(##sys#setslot in 7 'socket)
541	(##sys#setslot out 7 'socket)
542	(##sys#set-port-data! in data)
543	(##sys#set-port-data! out data)
544	(values in out) ) ) ) )
545
546(define (tcp-accept tcpl)
547  (##sys#check-structure tcpl 'tcp-listener)
548  (let* ((fd (##sys#slot tcpl 1))
549	 (tma (tcp-accept-timeout))
550	 (dla (and tma (+ tma (current-process-milliseconds)))))
551    (let loop ()
552      (when dla
553	(##sys#thread-block-for-timeout! ##sys#current-thread dla) )
554      (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
555      (##sys#thread-yield!)
556      (if (##sys#slot ##sys#current-thread 13)
557	  (##sys#signal-hook
558	   #:network-timeout-error
559	   'tcp-accept
560	   "accept operation timed out" tma fd) )
561      (let ((fd (accept fd #f #f)))
562	(cond ((not (eq? _invalid_socket fd))
563	       (io-ports 'tcp-accept fd))
564	      ((interrupted?)
565	       (##sys#dispatch-interrupt loop))
566	      (else
567	       (network-error 'tcp-accept "could not accept from listener" tcpl)))) ) ) )
568
569(define (tcp-accept-ready? tcpl)
570  (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
571  ;; XXX: This "knows" that check_fd_ready is implemented using a winsock2 call
572  (let ((f (check-fd-ready (##sys#slot tcpl 1))))
573    (when (eq? _socket_error f)
574      (network-error 'tcp-accept-ready? "cannot check socket for input" tcpl) )
575    (eq? 1 f) ) )
576
577(define get-socket-error
578  (foreign-lambda* int ((int socket))
579    "int err, optlen;"
580    "optlen = sizeof(err);"
581    "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == SOCKET_ERROR)"
582    "  C_return(SOCKET_ERROR);"
583    "C_return(err);"))
584
585(define (tcp-connect host . more)
586  (let* ((port (optional more #f))
587	 (tmc (tcp-connect-timeout))
588	 (dlc (and tmc (+ (current-process-milliseconds) tmc)))
589	 (addr (make-string _sockaddr_in_size)))
590    (##sys#check-string host)
591    (unless port
592      (set!-values (host port) (parse-host host "tcp"))
593      (unless port (##sys#signal-hook #:domain-error 'tcp-connect "no port specified" host)) )
594    (##sys#check-fixnum port)
595    (unless (gethostaddr addr host port)
596      (##sys#signal-hook #:network-error 'tcp-connect "cannot find host address" host) )
597    (let ((s (socket _af_inet _sock_stream 0)))
598      (when (eq? _invalid_socket s)
599	(network-error 'tcp-connect "cannot create socket" host port) )
600      (when (eq? _socket_error (set-socket-options s))
601	(network-error/close 'tcp-connect "error while setting up socket" s) )
602      (unless (##core#inline "make_socket_nonblocking" s)
603	(network-error/close 'tcp-connect "fcntl() failed" s) )
604      (let loop ()
605	(when (eq? _socket_error (connect s addr _sockaddr_in_size))
606	  (cond ((in-progress?) ; Wait till it's available via select/poll
607		 (when dlc
608		   (##sys#thread-block-for-timeout! ##sys#current-thread dlc))
609		 (##sys#thread-block-for-i/o! ##sys#current-thread s #:output)
610		 (##sys#thread-yield!)) ; Don't loop: it's connected now
611		((interrupted?)
612		 (##sys#dispatch-interrupt loop))
613		(else
614		 (network-error/close
615		  'tcp-connect "cannot connect to socket" s host port)))))
616      (let ((err (get-socket-error s)))
617	(cond ((eq? _socket_error err)
618	       (network-error/close 'tcp-connect "getsockopt() failed" s))
619	      ((fx> err 0)
620	       (close s)
621	       (network-error/code 'tcp-connect err "cannot create socket"))))
622      (io-ports 'tcp-connect s))) )
623
624(define (tcp-port->fileno p loc)
625  (let ((data (##sys#port-data p)))
626    (if (vector? data)			; a meagre test, but better than nothing
627	(##sys#slot data 0)
628	(error loc "argument does not appear to be a TCP port" p))))
629
630(define (tcp-addresses p)
631  (##sys#check-open-port p 'tcp-addresses)
632  (let ((fd (tcp-port->fileno p 'tcp-addresses)))
633    (values 
634     (or (getsockname fd)
635	 (network-error 'tcp-addresses "cannot compute local address" p) )
636     (or (getpeername fd)
637	 (network-error 'tcp-addresses "cannot compute remote address" p) ) ) ) )
638
639(define (tcp-port-numbers p)
640  (##sys#check-open-port p 'tcp-port-numbers)
641  (let ((fd (tcp-port->fileno p 'tcp-port-numbers)))
642    (let ((sp (getsockport fd))
643	  (pp (getpeerport fd)))
644      (when (eq? -1 sp)
645	(network-error 'tcp-port-numbers "cannot compute local port" p) )
646      (when (eq? -1 pp)
647	(network-error 'tcp-port-numbers "cannot compute remote port" p) )
648      (values sp pp))))
649
650(define (tcp-listener-port tcpl)
651  (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
652  (let* ((fd (##sys#slot tcpl 1))
653	 (port (getsockport fd)))
654    (when (eq? -1 port)
655      (network-error 'tcp-listener-port "cannot obtain listener port" tcpl fd) )
656    port) )
657
658(define (tcp-abandon-port p)
659  (##sys#check-open-port p 'tcp-abandon-port)
660  (##sys#setislot (##sys#port-data p) (##sys#slot p 1) #t))
661
662(define (tcp-listener-fileno l)
663  (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
664  (##sys#slot l 1) )
665
666)