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

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

merged trunk svn rev. 13239 into prerelease

File size: 22.7 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                   (cond ((fx< bufindex buflen)
419                          (##sys#scan-buffer-line
420                           buf 
421                           buflen
422                           bufindex
423                           (lambda (pos2 next)
424                             (let ((dest (##sys#make-string (fx- pos2 bufindex))))
425                               (##core#inline "C_substring_copy" buf dest bufindex pos2 0)
426                               (set! bufindex next)
427                               (cond ((eq? pos2 next) ; no line-terminator encountered
428                                      (read-input)
429                                      (if (fx>= bufindex buflen)
430                                          (or str "")
431                                          (loop (if str (##sys#string-append str dest) dest)) ) )
432                                     (else
433                                      (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
434                                      (if str (##sys#string-append str dest) dest)) ) ) ) ) )
435                         (else
436                          (read-input)
437                          (if (fx< bufindex buflen)
438                              (loop str)
439                              #!eof) ) ) ) ) ) )
440             (output
441              (lambda (s)
442                (let loop ((len (##sys#size s))
443                           (offset 0))
444                  (let* ((count (fxmin +output-chunk-size+ len))
445                         (n (##net#send fd s offset count 0)) )
446                    (cond ((eq? -1 n)
447                           (cond ((eq? errno _ewouldblock)
448                                  (when tmw
449                                    (##sys#thread-block-for-timeout! 
450                                     ##sys#current-thread
451                                     (fx+ (##sys#fudge 16) tmw) ) )
452                                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
453                                  (yield) 
454                                  (when (##sys#slot ##sys#current-thread 13)
455                                    (##sys#signal-hook
456                                     #:network-error
457                                     "write operation timed out" fd) )
458                                  (loop len offset) )
459                                 (else
460                                  (##sys#update-errno)
461                                  (##sys#signal-hook 
462                                   #:network-error
463                                   (##sys#string-append "cannot write to socket - " strerror) 
464                                   fd) ) ) )
465                          ((fx< n len)
466                           (loop (fx- len n) (fx+ offset n)) ) ) ) ) ) )
467             (out
468              (make-output-port
469               (if outbuf
470                   (lambda (s)
471                     (set! outbuf (##sys#string-append outbuf s))
472                     (when (fx>= (##sys#size outbuf) outbufsize)
473                       (output outbuf)
474                       (set! outbuf "") ) )
475                   (lambda (s) 
476                     (when (fx> (##sys#size s) 0)
477                       (output s)) ) )
478               (lambda ()
479                 (unless oclosed
480                   (set! oclosed #t)
481                   (when (and outbuf (fx> (##sys#size outbuf) 0))
482                     (output outbuf)
483                     (set! outbuf "") )
484                   (unless (##sys#slot data 2) (##net#shutdown fd _sd_send))
485                   (when (and iclosed (eq? -1 (##net#close fd)))
486                     (##sys#update-errno)
487                     (##sys#signal-hook
488                      #:network-error (##sys#string-append "cannot close socket output port - " strerror) fd) ) ) )
489               (and outbuf
490                    (lambda ()
491                      (when (fx> (##sys#size outbuf) 0)
492                        (output outbuf)
493                        (set! outbuf "") ) ) ) ) ) )
494        (##sys#setslot in 3 "(tcp)")
495        (##sys#setslot out 3 "(tcp)")
496        (##sys#setslot in 7 'socket)
497        (##sys#setslot out 7 'socket)
498        (##sys#setslot in 9 data)
499        (##sys#setslot out 9 data)
500        (values in out) ) ) ) )
501
502(define (tcp-accept tcpl)
503  (##sys#check-structure tcpl 'tcp-listener)
504  (let ((fd (##sys#slot tcpl 1))
505        (tma (tcp-accept-timeout)))
506    (let loop ()
507      (if (eq? 1 (##net#select fd))
508          (let ((fd (##net#accept fd #f #f)))
509            (when (eq? -1 fd)
510              (##sys#update-errno)
511              (##sys#signal-hook 
512               #:network-error 'tcp-accept (##sys#string-append "could not accept from listener - " strerror) 
513               tcpl) )
514            (##net#io-ports fd) )
515          (begin
516            (when tma
517              (##sys#thread-block-for-timeout! 
518               ##sys#current-thread
519               (fx+ (##sys#fudge 16) tma) ) )
520            (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
521            (yield)
522            (when (##sys#slot ##sys#current-thread 13)
523              (##sys#signal-hook
524               #:network-error
525               'tcp-accept
526               "accept operation timed out" fd) )
527            (loop) ) ) ) ) )
528
529(define (tcp-accept-ready? tcpl)
530  (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
531  (let ((f (##net#select (##sys#slot tcpl 1))))
532    (when (eq? -1 f)
533      (##sys#update-errno)
534      (##sys#signal-hook 
535       #:network-error 'tcp-accept-ready? (##sys#string-append "cannot check socket for input - " strerror) 
536       tcpl) )
537    (eq? 1 f) ) )
538
539(define get-socket-error
540  (foreign-lambda* int ((int socket))
541    "int err, optlen;"
542    "optlen = sizeof(err);"
543    "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)"
544    "return(-1);"
545    "return(err);"))
546
547(define general-strerror (foreign-lambda c-string "strerror" int))
548
549(define (tcp-connect host . more)
550  (let ((port (optional more #f))
551        (tmc (tcp-connect-timeout)))
552    (##sys#check-string host)
553    (unless port
554      (set!-values (host port) (##net#parse-host host "tcp"))
555      (unless port (##sys#signal-hook #:network-error 'tcp-connect "no port specified" host)) )
556    (##sys#check-exact port)
557    (let ((addr (make-string _sockaddr_in_size))
558          (s (##net#socket _af_inet _sock_stream 0)) )
559      (define (fail)
560        (##net#close s)
561        (##sys#update-errno)
562        (##sys#signal-hook 
563         #:network-error 'tcp-connect (##sys#string-append "cannot connect to socket - " strerror) 
564         host port) )
565      (when (eq? -1 s)
566        (##sys#update-errno)
567        (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "cannot create socket - " strerror) host port) )
568      (unless (##net#gethostaddr addr host port)
569        (##sys#signal-hook #:network-error 'tcp-connect "cannot find host address" host) )
570      (unless (##net#make-nonblocking s)
571        (##sys#update-errno)
572        (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "fcntl() failed - " strerror)) )
573      (when (eq? -1 (##net#connect s addr _sockaddr_in_size))
574        (if (eq? errno _einprogress)
575            (let loop ()
576              (let ((f (##net#select-write s)))
577                (when (eq? f -1) (fail))
578                (unless (eq? f 1)
579                  (when tmc
580                    (##sys#thread-block-for-timeout!
581                     ##sys#current-thread
582                     (fx+ (##sys#fudge 16) tmc) ) )
583                  (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
584                  (yield)
585                  (when (##sys#slot ##sys#current-thread 13)
586                    (##sys#signal-hook
587                     #:network-error
588                     'tcp-connect
589                     "connect operation timed out" s) )
590                  (loop) ) ) )
591            (fail) ) )
592      (let ((err (get-socket-error s)))
593        (cond ((= err -1) 
594               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "getsockopt() failed - " strerror)))
595              ((> err 0) 
596               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "cannot create socket - " (general-strerror err))))))
597      (##net#io-ports s) ) ) )
598
599(define (##sys#tcp-port->fileno p)
600  (let ((data (##sys#port-data p)))
601    (if (vector? data)                  ; a meagre test, but better than nothing
602        (##sys#slot data 0)
603        (error '##sys#tcp-port->fileno "argument does not appear to be a TCP port" p))))
604
605(define (tcp-addresses p)
606  (##sys#check-port p 'tcp-addresses)
607  (let ((fd (##sys#tcp-port->fileno p)))
608    (values
609     (or (##net#getsockname fd)
610         (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "cannot compute local address - " strerror) p) )
611     (or (##net#getpeername fd)
612         (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "cannot compute remote address - " strerror) p) ) ) ) )
613
614(define (tcp-port-numbers p)
615  (##sys#check-port p 'tcp-port-numbers)
616  (let ((fd (##sys#tcp-port->fileno p)))
617    (values
618     (or (##net#getsockport fd)
619         (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "cannot compute local port - " strerror) p) )
620     (or (##net#getpeerport fd)
621         (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "cannot compute remote port - " strerror) p) ) ) ) )
622
623(define (tcp-listener-port tcpl)
624  (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
625  (let* ((fd (##sys#slot tcpl 1))
626         (port (##net#getsockport fd)) )
627    (when (eq? -1 port)
628      (##sys#signal-hook
629       #:network-error 'tcp-listener-port (##sys#string-append "cannot obtain listener port - " strerror) 
630       tcpl fd) )
631    port) )
632
633(define (tcp-abandon-port p)
634  (##sys#check-port p 'tcp-abandon-port)
635  (##sys#setislot
636   (##sys#port-data p)
637   (if (##sys#slot p 1) 2 1)
638   #t) )
639
640(define (tcp-listener-fileno l)
641  (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
642  (##sys#slot l 1) )
Note: See TracBrowser for help on using the repository browser.