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