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

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

tcp ports allow accessing buffer and buffer size; wrapper for setting port data

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