source: project/chicken/trunk/tcp.scm @ 14101

Last change on this file since 14101 was 14101, checked in by Kon Lovett, 11 years ago

Applied the fix for dangling open ports suggested by Matt Jones.

File size: 22.9 KB
Line 
1;;;; tcp.scm - Networking stuff
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
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 extras scheduler)
31  (usual-integrations)
32  (fixnum-arithmetic)
33  (no-bound-checks)
34  (export tcp-close tcp-listen tcp-connect tcp-accept tcp-accept-ready? ##sys#tcp-port->fileno tcp-listener? tcp-addresses
35          tcp-abandon-port tcp-listener-port tcp-listener-fileno tcp-port-numbers tcp-buffer-size
36          tcp-read-timeout tcp-write-timeout tcp-accept-timeout tcp-connect-timeout)
37  (no-procedure-checks-for-usual-bindings)
38  (bound-to-procedure
39   ##net#socket ##net#bind ##net#connect ##net#listen ##net#accept make-parameter ##sys#string-append ##sys#tcp-port->fileno
40   ##sys#check-port ##sys#port-data ##sys#thread-block-for-i/o! make-string make-input-port make-output-port ##sys#substring
41   substring ##sys#make-c-string ##sys#schedule
42   ##net#close ##net#recv ##net#send ##net#select ##net#select-write ##net#gethostaddr ##net#io-ports ##sys#update-errno
43   ##sys#error ##sys#signal-hook ##net#getservbyname ##net#parse-host ##net#fresh-addr
44   ##net#bind-socket ##net#shutdown)
45  (foreign-declare #<<EOF
46#include <errno.h>
47#ifdef _WIN32
48# if _MSC_VER > 1300
49# include <winsock2.h>
50# include <ws2tcpip.h>
51# else
52# include <winsock.h>
53# endif
54/* Beware: winsock2.h must come BEFORE windows.h */
55# define socklen_t       int
56static WSADATA wsa;
57# define fcntl(a, b, c)  0
58# define EWOULDBLOCK     0
59# define EINPROGRESS     0
60# define typecorrect_getsockopt(socket, level, optname, optval, optlen) \
61    getsockopt(socket, level, optname, (char *)optval, optlen)
62#else
63# include <fcntl.h>
64# include <sys/types.h>
65# include <sys/socket.h>
66# include <sys/time.h>
67# include <netinet/in.h>
68# include <unistd.h>
69# include <netdb.h>
70# include <signal.h>
71# define closesocket     close
72# define INVALID_SOCKET  -1
73# define typecorrect_getsockopt getsockopt
74#endif
75
76#ifndef SD_RECEIVE
77# define SD_RECEIVE      0
78# define SD_SEND         1
79#endif
80
81#ifdef ECOS
82#include <sys/sockio.h>
83#endif
84
85static char addr_buffer[ 20 ];
86EOF
87) )
88
89(include "unsafe-declarations.scm")
90
91(register-feature! 'tcp)
92
93(define-foreign-variable errno int "errno")
94(define-foreign-variable strerror c-string "strerror(errno)")
95
96(define-foreign-type sockaddr* (pointer "struct sockaddr"))
97(define-foreign-type sockaddr_in* (pointer "struct sockaddr_in"))
98
99(define-foreign-variable _af_inet int "AF_INET")
100(define-foreign-variable _sock_stream int "SOCK_STREAM")
101(define-foreign-variable _sock_dgram int "SOCK_DGRAM")
102(define-foreign-variable _sockaddr_size int "sizeof(struct sockaddr)")
103(define-foreign-variable _sockaddr_in_size int "sizeof(struct sockaddr_in)")
104(define-foreign-variable _sd_receive int "SD_RECEIVE")
105(define-foreign-variable _sd_send int "SD_SEND")
106(define-foreign-variable _ipproto_tcp int "IPPROTO_TCP")
107(define-foreign-variable _invalid_socket int "INVALID_SOCKET")
108(define-foreign-variable _ewouldblock int "EWOULDBLOCK")
109(define-foreign-variable _einprogress int "EINPROGRESS")
110
111(define ##net#socket (foreign-lambda int "socket" int int int))
112(define ##net#bind (foreign-lambda int "bind" int scheme-pointer int))
113(define ##net#listen (foreign-lambda int "listen" int int))
114(define ##net#accept (foreign-lambda int "accept" int c-pointer c-pointer))
115(define ##net#close (foreign-lambda int "closesocket" int))
116(define ##net#recv (foreign-lambda int "recv" int scheme-pointer int int))
117(define ##net#shutdown (foreign-lambda int "shutdown" int int))
118(define ##net#connect (foreign-lambda int "connect" int scheme-pointer int))
119
120(define ##net#send
121  (foreign-lambda* int ((int s) (scheme-pointer msg) (int offset) (int len) (int flags))
122                   "return(send(s, (char *)msg+offset, len, flags));"))
123
124(define ##net#make-nonblocking
125  (foreign-lambda* bool ((int fd))
126    "int val = fcntl(fd, F_GETFL, 0);"
127    "if(val == -1) return(0);"
128    "return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);") )
129
130(define ##net#getsockname 
131  (foreign-lambda* c-string ((int s))
132    "struct sockaddr_in sa;"
133    "unsigned char *ptr;"
134    "int len = sizeof(struct sockaddr_in);"
135    "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)&len) != 0) return(NULL);"
136    "ptr = (unsigned char *)&sa.sin_addr;"
137    "sprintf(addr_buffer, \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
138    "return(addr_buffer);") )
139
140(define ##net#getsockport
141  (foreign-lambda* int ((int s))
142    "struct sockaddr_in sa;"
143    "int len = sizeof(struct sockaddr_in);"
144    "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) return(-1);"
145    "else return(ntohs(sa.sin_port));") )
146
147(define ##net#getpeerport
148 (foreign-lambda* int ((int s))
149   "struct sockaddr_in sa;"
150   "int len = sizeof(struct sockaddr_in);"
151   "if(getpeername(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) return(-1);"
152   "else return(ntohs(sa.sin_port));") )
153
154(define ##net#getpeername 
155  (foreign-lambda* c-string ((int s))
156    "struct sockaddr_in sa;"
157    "unsigned char *ptr;"
158    "unsigned int len = sizeof(struct sockaddr_in);"
159    "if(getpeername(s, (struct sockaddr *)&sa, ((unsigned int *)&len)) != 0) return(NULL);"
160    "ptr = (unsigned char *)&sa.sin_addr;"
161    "sprintf(addr_buffer, \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
162    "return(addr_buffer);") )
163
164(define ##net#startup
165  (foreign-lambda* bool () #<<EOF
166#ifdef _WIN32
167     return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);
168#else
169     signal(SIGPIPE, SIG_IGN);
170     return(1);
171#endif
172EOF
173) )
174
175(unless (##net#startup)
176  (##sys#signal-hook #:network-error "cannot initialize Winsock") )
177
178(define ##net#getservbyname 
179  (foreign-lambda* int ((c-string serv) (c-string proto))
180    "struct servent *se;
181     if((se = getservbyname(serv, proto)) == NULL) return(0);
182     else return(ntohs(se->s_port));") )     
183
184(define ##net#select
185  (foreign-lambda* int ((int fd))
186    "fd_set in;
187     struct timeval tm;
188     int rv;
189     FD_ZERO(&in);
190     FD_SET(fd, &in);
191     tm.tv_sec = tm.tv_usec = 0;
192     rv = select(fd + 1, &in, NULL, NULL, &tm);
193     if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
194     return(rv);") )
195
196(define ##net#select-write
197  (foreign-lambda* int ((int fd))
198    "fd_set out;
199     struct timeval tm;
200     int rv;
201     FD_ZERO(&out);
202     FD_SET(fd, &out);
203     tm.tv_sec = tm.tv_usec = 0;
204     rv = select(fd + 1, NULL, &out, NULL, &tm);
205     if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
206     return(rv);") )
207
208(define ##net#gethostaddr
209  (foreign-lambda* bool ((scheme-pointer saddr) (c-string host) (unsigned-short port))
210    "struct hostent *he = gethostbyname(host);"
211    "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
212    "if(he == NULL) return(0);"
213    "memset(addr, 0, sizeof(struct sockaddr_in));"
214    "addr->sin_family = AF_INET;"
215    "addr->sin_port = htons((short)port);"
216    "addr->sin_addr = *((struct in_addr *)he->h_addr);"
217    "return(1);") )
218
219(define (yield)
220  (##sys#call-with-current-continuation
221   (lambda (return)
222     (let ((ct ##sys#current-thread))
223       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
224       (##sys#schedule) ) ) ) )
225
226(define ##net#parse-host
227  (let ((substring substring))
228    (lambda (host proto)
229      (let ((len (##sys#size host)))
230        (let loop ((i 0))
231          (if (fx>= i len)
232              (values host #f)
233              (let ((c (##core#inline "C_subchar" host i)))
234                (if (char=? c #\:)                 
235                    (values
236                     (substring host (add1 i) len)
237                     (let* ((s (substring host 0 i))
238                            (p (##net#getservbyname s proto)) )
239                       (when (eq? 0 p)
240                         (##sys#update-errno)
241                         (##sys#signal-hook
242                          #:network-error 'tcp-connect (##sys#string-append "cannot compute port from service - " strerror)
243                          s) )
244                       p) )
245                    (loop (fx+ i 1)) ) ) ) ) ) ) ) )
246
247(define ##net#fresh-addr
248  (foreign-lambda* void ((scheme-pointer saddr) (unsigned-short port))
249    "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
250    "memset(addr, 0, sizeof(struct sockaddr_in));"
251    "addr->sin_family = AF_INET;"
252    "addr->sin_port = htons(port);"
253    "addr->sin_addr.s_addr = htonl(INADDR_ANY);") )
254
255(define (##net#bind-socket port style host)
256  (##sys#check-exact port)
257  (cond-expand
258   (unsafe)
259   (else
260    (when (or (fx< port 0) (fx>= port 65535))
261      (##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) ) ) )
262  (let ((s (##net#socket _af_inet style 0)))
263    (when (eq? _invalid_socket s)
264      (##sys#update-errno)
265      (##sys#error "cannot create socket") )
266    ;; PLT makes this an optional arg to tcp-listen. Should we as well?
267    (when (eq? -1 ((foreign-lambda* int ((int socket)) 
268                     "int yes = 1;
269                      return(setsockopt(socket, SOL_SOCKET, SO_REUSEADDR, (const char *)&yes, sizeof(int)));") 
270                   s) )
271      (##sys#update-errno)
272      (##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "error while setting up socket - " strerror) s) )
273    (let ((addr (make-string _sockaddr_in_size)))
274      (if host
275          (unless (##net#gethostaddr addr host port)
276            (##sys#signal-hook #:network-error 'tcp-listen "getting listener host IP failed - " host port) )
277          (##net#fresh-addr addr port) )
278      (let ((b (##net#bind s addr _sockaddr_in_size)))
279        (when (eq? -1 b)
280          (##sys#update-errno)
281          (##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "cannot bind to socket - " strerror) s port) )
282        (values s addr) ) ) ) )
283
284(define-constant default-backlog 10)
285
286(define (tcp-listen port . more)
287  (let-optionals more ((w default-backlog) (host #f))
288    (let-values (((s addr) (##net#bind-socket port _sock_stream host)))
289      (##sys#check-exact w)
290      (let ((l (##net#listen s w)))
291        (when (eq? -1 l)
292          (##sys#update-errno)
293          (##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "cannot listen on socket - " strerror) s port) )
294        (##sys#make-structure 'tcp-listener s) ) ) ) )
295
296(define (tcp-listener? x) 
297  (and (##core#inline "C_blockp" x)
298       (##sys#structure? x 'tcp-listener) ) )
299
300(define (tcp-close tcpl)
301  (##sys#check-structure tcpl 'tcp-listener)
302  (let ((s (##sys#slot tcpl 1)))
303    (when (fx= -1 (##net#close s))
304      (##sys#update-errno)
305      (##sys#signal-hook #:network-error 'tcp-close (##sys#string-append "cannot close TCP socket - " strerror) tcpl) ) ) )
306
307(define-constant +input-buffer-size+ 1024)
308(define-constant +output-chunk-size+ 8192)
309
310(define tcp-buffer-size (make-parameter #f))
311(define tcp-read-timeout)
312(define tcp-write-timeout)
313(define tcp-connect-timeout)
314(define tcp-accept-timeout)
315
316(let ()
317  (define ((check loc) x)
318    (when x (##sys#check-exact x loc))
319    x)
320  (define minute (* 60 1000))
321  (set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout)))
322  (set! tcp-write-timeout (make-parameter minute (check 'tcp-write-timeout))) 
323  (set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout))) 
324  (set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )
325
326(define ##net#io-ports
327  (let ((make-input-port make-input-port)
328        (make-output-port make-output-port) 
329        (tbs tcp-buffer-size)
330        (make-string make-string) )
331    (lambda (fd)
332      (unless (##net#make-nonblocking fd)
333        (##sys#update-errno)
334        (##sys#signal-hook #:network-error (##sys#string-append "cannot create TCP ports - " strerror)) )
335      (let* ((buf (make-string +input-buffer-size+))
336             (data (vector fd #f #f))
337             (buflen 0)
338             (bufindex 0)
339             (iclosed #f) 
340             (oclosed #f)
341             (outbufsize (tbs))
342             (outbuf (and outbufsize (fx> outbufsize 0) ""))
343             (tmr (tcp-read-timeout))
344             (tmw (tcp-write-timeout))
345             (read-input
346              (lambda ()
347                (let loop ()
348                  (let ((n (##net#recv fd buf +input-buffer-size+ 0)))
349                    (cond ((eq? -1 n)
350                           (cond ((eq? errno _ewouldblock) 
351                                  (when tmr
352                                    (##sys#thread-block-for-timeout! 
353                                     ##sys#current-thread
354                                     (fx+ (##sys#fudge 16) tmr) ) )
355                                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
356                                  (yield)
357                                  (when (##sys#slot ##sys#current-thread 13)
358                                    (##sys#signal-hook
359                                     #:network-error
360                                     "read operation timed out" fd) )
361                                  (loop) )
362                                 (else
363                                  (##sys#update-errno)
364                                  (##sys#signal-hook 
365                                   #:network-error
366                                   (##sys#string-append "cannot read from socket - " strerror) 
367                                   fd) ) ) )
368                          (else
369                           (set! buflen n)
370                           (set! bufindex 0) ) ) ) ) ) )
371             (in
372              (make-input-port
373               (lambda ()
374                 (when (fx>= bufindex buflen)
375                   (read-input))
376                 (if (fx>= bufindex buflen)
377                     #!eof
378                     (let ((c (##core#inline "C_subchar" buf bufindex)))
379                       (set! bufindex (fx+ bufindex 1))
380                       c) ) )
381               (lambda ()
382                 (or (fx< bufindex buflen)
383                     (let ((f (##net#select fd)))
384                       (when (eq? f -1)
385                         (##sys#update-errno)
386                         (##sys#signal-hook
387                          #:network-error
388                          (##sys#string-append "cannot check socket for input - " strerror) 
389                          fd) )
390                       (eq? f 1) ) ) )
391               (lambda ()
392                 (unless iclosed
393                   (set! iclosed #t)
394                   (unless (##sys#slot data 1) (##net#shutdown fd _sd_receive))
395                   (when (and oclosed (eq? -1 (##net#close fd)))
396                     (##sys#update-errno)
397                     (##sys#signal-hook
398                      #:network-error
399                      (##sys#string-append "cannot close socket input port - " strerror)
400                      fd) ) ) )
401               #f
402               (lambda (p n dest start) ; read-string!
403                 (let loop ((n n) (m 0) (start start))
404                   (cond ((eq? n 0) m)
405                         ((fx< bufindex buflen)
406                          (let* ((rest (fx- buflen bufindex))
407                                 (n2 (if (fx< n rest) n rest)))
408                            (##core#inline "C_substring_copy" buf dest bufindex (fx+ bufindex n2) start)
409                            (set! bufindex (fx+ bufindex n2))
410                            (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )
411                         (else
412                          (read-input)
413                          (if (eq? buflen 0) 
414                              m
415                              (loop n m start) ) ) ) ) )
416               (lambda (p limit)        ; read-line
417                 (let loop ((str #f)
418                            (limit (or limit (##sys#fudge 21))))
419                   (cond ((fx< bufindex buflen)
420                          (##sys#scan-buffer-line
421                           buf 
422                           (fxmin buflen limit)
423                           bufindex
424                           (lambda (pos2 next)
425                             (let* ((len (fx- pos2 bufindex))
426                                    (dest (##sys#make-string len)))
427                               (##core#inline "C_substring_copy" buf dest bufindex pos2 0)
428                               (set! bufindex next)
429                               (cond ((eq? pos2 limit) ; no line-terminator, hit limit
430                                      (if str (##sys#string-append str dest) dest))
431                                     ((eq? pos2 next)  ; no line-terminator, hit buflen
432                                      (read-input)
433                                      (if (fx>= bufindex buflen)
434                                          (or str "")
435                                          (loop (if str (##sys#string-append str dest) dest)
436                                                (fx- limit len)) ) )
437                                     (else
438                                      (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
439                                      (if str (##sys#string-append str dest) dest)) ) ) ) ) )
440                         (else
441                          (read-input)
442                          (if (fx< bufindex buflen)
443                              (loop str limit)
444                              #!eof) ) ) ) ) ) )
445             (output
446              (lambda (s)
447                (let loop ((len (##sys#size s))
448                           (offset 0))
449                  (let* ((count (fxmin +output-chunk-size+ len))
450                         (n (##net#send fd s offset count 0)) )
451                    (cond ((eq? -1 n)
452                           (cond ((eq? errno _ewouldblock)
453                                  (when tmw
454                                    (##sys#thread-block-for-timeout! 
455                                     ##sys#current-thread
456                                     (fx+ (##sys#fudge 16) tmw) ) )
457                                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
458                                  (yield) 
459                                  (when (##sys#slot ##sys#current-thread 13)
460                                    (##sys#signal-hook
461                                     #:network-error
462                                     "write operation timed out" fd) )
463                                  (loop len offset) )
464                                 (else
465                                  (##sys#update-errno)
466                                  (##sys#signal-hook 
467                                   #:network-error
468                                   (##sys#string-append "cannot write to socket - " strerror) 
469                                   fd) ) ) )
470                          ((fx< n len)
471                           (loop (fx- len n) (fx+ offset n)) ) ) ) ) ) )
472             (out
473              (make-output-port
474               (if outbuf
475                   (lambda (s)
476                     (set! outbuf (##sys#string-append outbuf s))
477                     (when (fx>= (##sys#size outbuf) outbufsize)
478                       (output outbuf)
479                       (set! outbuf "") ) )
480                   (lambda (s) 
481                     (when (fx> (##sys#size s) 0)
482                       (output s)) ) )
483               (lambda ()
484                 (unless oclosed
485                   (set! oclosed #t)
486                   (when (and outbuf (fx> (##sys#size outbuf) 0))
487                     (output outbuf)
488                     (set! outbuf "") )
489                   (unless (##sys#slot data 2) (##net#shutdown fd _sd_send))
490                   (when (and iclosed (eq? -1 (##net#close fd)))
491                     (##sys#update-errno)
492                     (##sys#signal-hook
493                      #:network-error (##sys#string-append "cannot close socket output port - " strerror) fd) ) ) )
494               (and outbuf
495                    (lambda ()
496                      (when (fx> (##sys#size outbuf) 0)
497                        (output outbuf)
498                        (set! outbuf "") ) ) ) ) ) )
499        (##sys#setslot in 3 "(tcp)")
500        (##sys#setslot out 3 "(tcp)")
501        (##sys#setslot in 7 'socket)
502        (##sys#setslot out 7 'socket)
503        (##sys#setslot in 9 data)
504        (##sys#setslot out 9 data)
505        (values in out) ) ) ) )
506
507(define (tcp-accept tcpl)
508  (##sys#check-structure tcpl 'tcp-listener)
509  (let ((fd (##sys#slot tcpl 1))
510        (tma (tcp-accept-timeout)))
511    (let loop ()
512      (if (eq? 1 (##net#select fd))
513          (let ((fd (##net#accept fd #f #f)))
514            (when (eq? -1 fd)
515              (##sys#update-errno)
516              (##sys#signal-hook 
517               #:network-error 'tcp-accept (##sys#string-append "could not accept from listener - " strerror) 
518               tcpl) )
519            (##net#io-ports fd) )
520          (begin
521            (when tma
522              (##sys#thread-block-for-timeout! 
523               ##sys#current-thread
524               (fx+ (##sys#fudge 16) tma) ) )
525            (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
526            (yield)
527            (when (##sys#slot ##sys#current-thread 13)
528              (##sys#signal-hook
529               #:network-error
530               'tcp-accept
531               "accept operation timed out" fd) )
532            (loop) ) ) ) ) )
533
534(define (tcp-accept-ready? tcpl)
535  (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
536  (let ((f (##net#select (##sys#slot tcpl 1))))
537    (when (eq? -1 f)
538      (##sys#update-errno)
539      (##sys#signal-hook 
540       #:network-error 'tcp-accept-ready? (##sys#string-append "cannot check socket for input - " strerror) 
541       tcpl) )
542    (eq? 1 f) ) )
543
544(define get-socket-error
545  (foreign-lambda* int ((int socket))
546    "int err, optlen;"
547    "optlen = sizeof(err);"
548    "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)"
549    "return(-1);"
550    "return(err);"))
551
552(define general-strerror (foreign-lambda c-string "strerror" int))
553
554(define (tcp-connect host . more)
555  (let ((port (optional more #f))
556        (tmc (tcp-connect-timeout)))
557    (##sys#check-string host)
558    (unless port
559      (set!-values (host port) (##net#parse-host host "tcp"))
560      (unless port (##sys#signal-hook #:network-error 'tcp-connect "no port specified" host)) )
561    (##sys#check-exact port)
562    (let ((addr (make-string _sockaddr_in_size))
563          (s (##net#socket _af_inet _sock_stream 0)) )
564      (define (fail)
565        (##net#close s)
566        (##sys#update-errno)
567        (##sys#signal-hook 
568         #:network-error 'tcp-connect (##sys#string-append "cannot connect to socket - " strerror) 
569         host port) )
570      (when (eq? -1 s)
571        (##sys#update-errno)
572        (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "cannot create socket - " strerror) host port) )
573      (unless (##net#gethostaddr addr host port)
574        (##sys#signal-hook #:network-error 'tcp-connect "cannot find host address" host) )
575      (unless (##net#make-nonblocking s)
576        (##sys#update-errno)
577        (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "fcntl() failed - " strerror)) )
578      (when (eq? -1 (##net#connect s addr _sockaddr_in_size))
579        (if (eq? errno _einprogress)
580            (let loop ()
581              (let ((f (##net#select-write s)))
582                (when (eq? f -1) (fail))
583                (unless (eq? f 1)
584                  (when tmc
585                    (##sys#thread-block-for-timeout!
586                     ##sys#current-thread
587                     (fx+ (##sys#fudge 16) tmc) ) )
588                  (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
589                  (yield)
590                  (when (##sys#slot ##sys#current-thread 13)
591                    (##sys#signal-hook
592                     #:network-error
593                     'tcp-connect
594                     "connect operation timed out" s) )
595                  (loop) ) ) )
596            (fail) ) )
597      (let ((err (get-socket-error s)))
598        (cond ((= err -1)
599               (##net#close s)
600               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "getsockopt() failed - " strerror)))
601              ((> err 0)
602               (##net#close s)
603               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "cannot create socket - " (general-strerror err))))))
604      (##net#io-ports s) ) ) )
605
606(define (##sys#tcp-port->fileno p)
607  (let ((data (##sys#port-data p)))
608    (if (vector? data)                  ; a meagre test, but better than nothing
609        (##sys#slot data 0)
610        (error '##sys#tcp-port->fileno "argument does not appear to be a TCP port" p))))
611
612(define (tcp-addresses p)
613  (##sys#check-port p 'tcp-addresses)
614  (let ((fd (##sys#tcp-port->fileno p)))
615    (values
616     (or (##net#getsockname fd)
617         (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "cannot compute local address - " strerror) p) )
618     (or (##net#getpeername fd)
619         (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "cannot compute remote address - " strerror) p) ) ) ) )
620
621(define (tcp-port-numbers p)
622  (##sys#check-port p 'tcp-port-numbers)
623  (let ((fd (##sys#tcp-port->fileno p)))
624    (values
625     (or (##net#getsockport fd)
626         (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "cannot compute local port - " strerror) p) )
627     (or (##net#getpeerport fd)
628         (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "cannot compute remote port - " strerror) p) ) ) ) )
629
630(define (tcp-listener-port tcpl)
631  (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
632  (let* ((fd (##sys#slot tcpl 1))
633         (port (##net#getsockport fd)) )
634    (when (eq? -1 port)
635      (##sys#signal-hook
636       #:network-error 'tcp-listener-port (##sys#string-append "cannot obtain listener port - " strerror) 
637       tcpl fd) )
638    port) )
639
640(define (tcp-abandon-port p)
641  (##sys#check-port p 'tcp-abandon-port)
642  (##sys#setislot
643   (##sys#port-data p)
644   (if (##sys#slot p 1) 2 1)
645   #t) )
646
647(define (tcp-listener-fileno l)
648  (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
649  (##sys#slot l 1) )
Note: See TracBrowser for help on using the repository browser.