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

Last change on this file since 13300 was 13300, checked in by felix winkelmann, 11 years ago

applied read-lime-limit patch by Jim Ursetto

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               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "getsockopt() failed - " strerror)))
600              ((> err 0) 
601               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "cannot create socket - " (general-strerror err))))))
602      (##net#io-ports s) ) ) )
603
604(define (##sys#tcp-port->fileno p)
605  (let ((data (##sys#port-data p)))
606    (if (vector? data)                  ; a meagre test, but better than nothing
607        (##sys#slot data 0)
608        (error '##sys#tcp-port->fileno "argument does not appear to be a TCP port" p))))
609
610(define (tcp-addresses p)
611  (##sys#check-port p 'tcp-addresses)
612  (let ((fd (##sys#tcp-port->fileno p)))
613    (values
614     (or (##net#getsockname fd)
615         (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "cannot compute local address - " strerror) p) )
616     (or (##net#getpeername fd)
617         (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "cannot compute remote address - " strerror) p) ) ) ) )
618
619(define (tcp-port-numbers p)
620  (##sys#check-port p 'tcp-port-numbers)
621  (let ((fd (##sys#tcp-port->fileno p)))
622    (values
623     (or (##net#getsockport fd)
624         (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "cannot compute local port - " strerror) p) )
625     (or (##net#getpeerport fd)
626         (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "cannot compute remote port - " strerror) p) ) ) ) )
627
628(define (tcp-listener-port tcpl)
629  (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
630  (let* ((fd (##sys#slot tcpl 1))
631         (port (##net#getsockport fd)) )
632    (when (eq? -1 port)
633      (##sys#signal-hook
634       #:network-error 'tcp-listener-port (##sys#string-append "cannot obtain listener port - " strerror) 
635       tcpl fd) )
636    port) )
637
638(define (tcp-abandon-port p)
639  (##sys#check-port p 'tcp-abandon-port)
640  (##sys#setislot
641   (##sys#port-data p)
642   (if (##sys#slot p 1) 2 1)
643   #t) )
644
645(define (tcp-listener-fileno l)
646  (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
647  (##sys#slot l 1) )
Note: See TracBrowser for help on using the repository browser.