source: project/chicken/branches/prerelease/tcp.scm @ 13178

Last change on this file since 13178 was 10911, checked in by Ivan Raikov, 12 years ago

Merged trunk with prerelease.

File size: 23.2 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 "can not 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 (##core#undefined))))
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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not 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 "can not create socket - " strerror) host port) )
582      (unless (##net#gethostaddr addr host port)
583        (##sys#signal-hook #:network-error 'tcp-connect "can not 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               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "getsockopt() failed - " strerror)))
609              ((> err 0) 
610               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "can not create socket - " (general-strerror err))))))
611      (##net#io-ports s) ) ) )
612
613(define (##sys#tcp-port->fileno p)
614  (##sys#slot (##sys#port-data p) 0) )
615
616(define (tcp-addresses p)
617  (let ((fd (##sys#tcp-port->fileno p)))
618    (values
619     (or (##net#getsockname fd)
620         (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "can not compute local address - " strerror) p) )
621     (or (##net#getpeername fd)
622         (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "can not compute remote address - " strerror) p) ) ) ) )
623
624(define (tcp-port-numbers p)
625 (let ((fd (##sys#tcp-port->fileno p)))
626   (values
627    (or (##net#getsockport fd)
628        (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "can not compute local port - " strerror) p) )
629    (or (##net#getpeerport fd)
630        (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "can not compute remote port - " strerror) p) ) ) ) )
631
632(define (tcp-listener-port tcpl)
633  (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
634  (let* ((fd (##sys#slot tcpl 1))
635         (port (##net#getsockport fd)) )
636    (when (eq? -1 port)
637      (##sys#signal-hook
638       #:network-error 'tcp-listener-port (##sys#string-append "can not obtain listener port - " strerror) 
639       tcpl fd) )
640    port) )
641
642(define (tcp-abandon-port p)
643  (##sys#check-port p 'tcp-abandon-port)
644  (##sys#setislot
645   (##sys#port-data p)
646   (if (##sys#slot p 1) 2 1)
647   #t) )
648
649(define (tcp-listener-fileno l)
650  (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
651  (##sys#slot l 1) )
Note: See TracBrowser for help on using the repository browser.