On 6/13/05, felix winkelmann <[EMAIL PROTECTED]> wrote:
>
> Ahem, no. Well it does, but it doesn't print the error message on retry.
> Give me a sec...
>
I forgot: you also need a new tcp.scm (attached).
BTW, is it somehow possible to nail down under what circumstances
the error occurs? (client, request/reply data, ..)
cheers,
felix
;;;; tcp.scm - Networking stuff
;
; Copyright (c) 2000-2005, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
; disclaimer.
; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
; disclaimer in the documentation and/or other materials provided with the distribution.
; Neither the name of the author nor the names of its contributors may be used to endorse or promote
; products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;
; Send bugs, suggestions and ideas to:
;
; [EMAIL PROTECTED]
;
; Felix L. Winkelmann
; Unter den Gleichen 1
; 37130 Gleichen
; Germany
(declare
(unit tcp)
(uses extras scheduler)
(usual-integrations)
(fixnum-arithmetic)
(no-bound-checks)
(export tcp-close tcp-listen tcp-connect tcp-accept tcp-accept-ready? ##sys#tcp-port->fileno tcp-listener? tcp-addresses
tcp-abandon-port tcp-listener-port tcp-listener-fileno)
(bound-to-procedure
##net#socket ##net#bind ##net#connect ##net#listen ##net#accept
##net#close ##net#recv ##net#send ##net#select ##net#select-write ##net#gethostaddr ##net#io-ports ##sys#update-errno
##sys#error ##sys#signal-hook ##net#getservbyname ##net#parse-host ##net#fresh-addr
##net#bind-socket ##net#shutdown)
(foreign-declare #<<EOF
#include <errno.h>
#ifdef _WIN32
# include <winsock2.h>
static WSADATA wsa;
# define fcntl(a, b, c) 0
# define EWOULDBLOCK 0
# define EINPROGRESS 0
#else
# include <fcntl.h>
# include <sys/types.h>
# include <sys/socket.h>
# include <sys/time.h>
# include <netinet/in.h>
# include <unistd.h>
# include <netdb.h>
# define SD_RECEIVE 0
# define SD_SEND 1
# define closesocket close
# define INVALID_SOCKET -1
#endif
static char addr_buffer[ 20 ];
EOF
) )
(register-feature! 'tcp)
(cond-expand
[unsafe
(eval-when (compile)
(define-macro (##sys#check-structure x y . _) '(##core#undefined))
(define-macro (##sys#check-range x y z) '(##core#undefined))
(define-macro (##sys#check-pair x) '(##core#undefined))
(define-macro (##sys#check-list x) '(##core#undefined))
(define-macro (##sys#check-symbol x) '(##core#undefined))
(define-macro (##sys#check-string x) '(##core#undefined))
(define-macro (##sys#check-char x) '(##core#undefined))
(define-macro (##sys#check-exact x) '(##core#undefined))
(define-macro (##sys#check-port x) '(##core#undefined))
(define-macro (##sys#check-number x) '(##core#undefined))
(define-macro (##sys#check-byte-vector x) '(##core#undefined)) ) ]
[else] )
(define-foreign-variable errno int "errno")
(define-foreign-variable strerror c-string "strerror(errno)")
(define-foreign-type sockaddr* (pointer "struct sockaddr"))
(define-foreign-type sockaddr_in* (pointer "struct sockaddr_in"))
(define-foreign-variable _af_inet int "AF_INET")
(define-foreign-variable _sock_stream int "SOCK_STREAM")
(define-foreign-variable _sock_dgram int "SOCK_DGRAM")
(define-foreign-variable _sockaddr_size int "sizeof(struct sockaddr)")
(define-foreign-variable _sockaddr_in_size int "sizeof(struct sockaddr_in)")
(define-foreign-variable _sd_receive int "SD_RECEIVE")
(define-foreign-variable _sd_send int "SD_SEND")
(define-foreign-variable _ipproto_tcp int "IPPROTO_TCP")
(define-foreign-variable _invalid_socket int "INVALID_SOCKET")
(define-foreign-variable _ewouldblock int "EWOULDBLOCK")
(define-foreign-variable _einprogress int "EINPROGRESS")
(define ##net#socket (foreign-lambda int "socket" int int int))
(define ##net#bind (foreign-lambda int "bind" int scheme-pointer int))
(define ##net#listen (foreign-lambda int "listen" int int))
(define ##net#accept (foreign-lambda int "accept" int c-pointer c-pointer))
(define ##net#close (foreign-lambda int "closesocket" int))
(define ##net#send (foreign-lambda int "send" int scheme-pointer int int))
(define ##net#recv (foreign-lambda int "recv" int scheme-pointer int int))
(define ##net#shutdown (foreign-lambda int "shutdown" int int))
(define ##net#connect (foreign-lambda int "connect" int scheme-pointer int))
(define ##net#make-nonblocking
(foreign-lambda* bool ([int fd])
"int val = fcntl(fd, F_GETFL, 0);"
"if(val == -1) return(0);"
"return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);") )
(define ##net#getsockname
(foreign-lambda* c-string ([int s])
"struct sockaddr_in sa;"
"unsigned char *ptr;"
"int len = sizeof(struct sockaddr_in);"
"if(getsockname(s, (struct sockaddr *)&sa, &len) != 0) return(NULL);"
"ptr = (unsigned char *)&sa.sin_addr;"
"sprintf(addr_buffer, \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
"return(addr_buffer);") )
(define ##net#getsockport
(foreign-lambda* int ([int s])
"struct sockaddr_in sa;"
"unsigned char *ptr;"
"int len = sizeof(struct sockaddr_in);"
"if(getsockname(s, (struct sockaddr *)&sa, &len) != 0) return(-1);"
"else return(ntohs(sa.sin_port));") )
(define ##net#getpeername
(foreign-lambda* c-string ([int s])
"struct sockaddr_in sa;"
"unsigned char *ptr;"
"int len = sizeof(struct sockaddr_in);"
"if(getpeername(s, (struct sockaddr *)&sa, &len) != 0) return(NULL);"
"ptr = (unsigned char *)&sa.sin_addr;"
"sprintf(addr_buffer, \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
"return(addr_buffer);") )
(define ##net#startup
(foreign-lambda* bool () #<<EOF
#ifdef _WIN32
return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);
#else
return(1);
#endif
EOF
) )
(unless (##net#startup)
(##sys#signal-hook #:network-error "can not initialize Winsock") )
(define ##net#getservbyname
(foreign-lambda* int ((c-string serv) (c-string proto))
"struct servent *se;
if((se = getservbyname(serv, proto)) == NULL) return(0);
else return(se->s_port);") )
(define ##net#select
(foreign-lambda* int ((int fd))
"fd_set in;
struct timeval tm;
int rv;
FD_ZERO(&in);
FD_SET(fd, &in);
tm.tv_sec = tm.tv_usec = 0;
rv = select(fd + 1, &in, NULL, NULL, &tm);
if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
return(rv);") )
(define ##net#select-write
(foreign-lambda* int ((int fd))
"fd_set out;
struct timeval tm;
int rv;
FD_ZERO(&out);
FD_SET(fd, &out);
tm.tv_sec = tm.tv_usec = 0;
rv = select(fd + 1, NULL, &out, NULL, &tm);
if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
return(rv);") )
(define ##net#gethostaddr
(foreign-lambda* bool ((scheme-pointer saddr) (c-string host) (unsigned-short port))
"struct hostent *he = gethostbyname(host);"
"struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
"if(he == NULL) return(0);"
"memset(addr, 0, sizeof(struct sockaddr_in));"
"addr->sin_family = AF_INET;"
"addr->sin_port = htons((short)port);"
"addr->sin_addr = *((struct in_addr *)he->h_addr);"
"return(1);") )
(define (yield)
(##sys#call-with-current-continuation
(lambda (return)
(let ((ct ##sys#current-thread))
(##sys#setslot ct 1 (lambda () (return (##core#undefined))))
(##sys#schedule) ) ) ) )
(define ##net#parse-host
(let ([substring substring])
(lambda (host proto)
(let ([len (##sys#size host)])
(let loop ([i 0])
(if (fx>= i len)
(values host #f)
(let ([c (##core#inline "C_subchar" host i)])
(if (char=? c #\:)
(values
(substring host (add1 i) len)
(let* ([s (substring host 0 i)]
[p (##net#getservbyname s proto)] )
(when (eq? 0 p)
(##sys#update-errno)
(##sys#signal-hook
#:network-error 'tcp-connect (##sys#string-append "can not compute port from service - " strerror)
s) )
p) )
(loop (fx+ i 1)) ) ) ) ) ) ) ) )
(define ##net#fresh-addr
(foreign-lambda* void ((scheme-pointer saddr) (unsigned-short port))
"struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
"memset(addr, 0, sizeof(struct sockaddr_in));"
"addr->sin_family = AF_INET;"
"addr->sin_port = htons(port);"
"addr->sin_addr.s_addr = htonl(INADDR_ANY);") )
(define (##net#bind-socket port style host)
(##sys#check-exact port)
(let ([s (##net#socket _af_inet style 0)])
(when (eq? _invalid_socket s)
(##sys#update-errno)
(##sys#error "can not create socket") )
;; PLT makes this an optional arg to tcp-listen. Should we as well?
(when (eq? -1 ((foreign-lambda* int ((int socket))
"int yes = 1;
return(setsockopt(socket, SOL_SOCKET, SO_REUSEADDR, (const char *)&yes, sizeof(int)));")
s) )
(##sys#update-errno)
(##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "error while setting up socket - " strerror) s) )
(let ([addr (make-string _sockaddr_in_size)])
(if host
(unless (##net#gethostaddr addr host port)
(##sys#signal-hook #:network-error 'tcp-listen "getting listener host IP failed - " host port) )
(##net#fresh-addr addr port) )
(let ([b (##net#bind s addr _sockaddr_in_size)])
(when (eq? -1 b)
(##sys#update-errno)
(##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "can not bind to socket - " strerror) s port) )
(values s addr) ) ) ) )
(define-constant default-backlog 10)
(define (tcp-listen port . more)
(let-optionals more ([w default-backlog] [host #f])
(let-values ([(s addr) (##net#bind-socket port _sock_stream host)])
(##sys#check-exact w)
(let ([l (##net#listen s w)])
(when (eq? -1 l)
(##sys#update-errno)
(##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "can not listen on socket - " strerror) s port) )
(##sys#make-structure 'tcp-listener s) ) ) ) )
(define (tcp-listener? x)
(and (##core#inline "C_blockp" x)
(##sys#structure? x 'tcp-listener) ) )
(define (tcp-close tcpl)
(##sys#check-structure tcpl 'tcp-listener)
(let ([s (##sys#slot tcpl 1)])
(when (fx= -1 (##net#close s))
(##sys#update-errno)
(##sys#signal-hook #:network-error 'tcp-close (##sys#string-append "can not close TCP socket - " strerror) tcpl) ) ) )
(define-constant buffer-size 1024)
(define ##net#io-ports
(let ([make-input-port make-input-port]
[make-output-port make-output-port]
[make-string make-string]
[substring substring] )
(lambda (fd)
(unless (##net#make-nonblocking fd)
(##sys#update-errno)
(##sys#signal-hook #:network-error (##sys#string-append "can not create TCP ports - " strerror)) )
(let* ([buf (make-string buffer-size)]
[data (vector fd #f #f)]
[buflen 0]
[bufindex 0]
[iclosed #f]
[oclosed #f]
[in
(make-input-port
(lambda ()
(when (fx>= bufindex buflen)
(let ([n (let loop ()
(let ([n (##net#recv fd buf buffer-size 0)])
(if (eq? -1 n)
(if (eq? errno _ewouldblock)
(begin
(##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
(yield)
(loop) )
(begin
(##sys#update-errno)
(##sys#signal-hook
#:network-error
(##sys#string-append "can not read from socket - " strerror)
fd) ) )
n) ) ) ] )
(set! buflen n)
(set! bufindex 0) ) )
(if (fx>= bufindex buflen)
(end-of-file)
(let ([c (##core#inline "C_subchar" buf bufindex)])
(set! bufindex (fx+ bufindex 1))
c) ) )
(lambda ()
(or (fx< bufindex buflen)
(let ([f (##net#select fd)])
(when (eq? f -1)
(##sys#update-errno)
(##sys#signal-hook #:network-error (##sys#string-append "can not check socket for input - " strerror)
fd) )
(eq? f 1) ) ) )
(lambda ()
(unless iclosed
(set! iclosed #t)
(unless (##sys#slot data 1) (##net#shutdown fd _sd_receive))
(when (and oclosed (eq? -1 (##net#close fd)))
(##sys#update-errno)
(##sys#signal-hook #:network-error (##sys#string-append "can not close socket input port - " strerror)
fd) ) ) ) ) ]
[out
(make-output-port
(lambda (s)
(let ([len (##sys#size s)])
(let loop ()
(let ([n (##net#send fd s len 0)])
(cond [(eq? -1 n)
(if (eq? errno _ewouldblock)
(begin
;(##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
(yield)
(loop) )
(begin
(##sys#update-errno)
(##sys#signal-hook
#:network-error (##sys#string-append "can not write to socket - " strerror) fd s) ) ) ]
[(fx< n len)
(set! s (substring s n len))
(set! len (##sys#size s))
(loop) ] ) ) ) ) )
(lambda ()
(unless oclosed
(set! oclosed #t)
(unless (##sys#slot data 2) (##net#shutdown fd _sd_send))
(when (and iclosed (eq? -1 (##net#close fd)))
(##sys#update-errno)
(##sys#signal-hook
#:network-error (##sys#string-append "can not close socket output port - " strerror) fd) ) ) ) ) ] )
(##sys#setslot in 3 "(tcp)")
(##sys#setslot out 3 "(tcp)")
(##sys#setslot in 7 'socket)
(##sys#setslot out 7 'socket)
(##sys#setslot (##sys#port-data in) 0 data)
(##sys#setslot (##sys#port-data out) 0 data)
(values in out) ) ) ) )
(define (tcp-accept tcpl)
(##sys#check-structure tcpl 'tcp-listener)
(let ([fd (##sys#slot tcpl 1)])
(let loop ()
(if (eq? 1 (##net#select fd))
(let ([fd (##net#accept fd #f #f)])
(when (eq? -1 fd)
(##sys#update-errno)
(##sys#signal-hook
#:network-error 'tcp-accept (##sys#string-append "could not accept from listener - " strerror)
tcpl) )
(##net#io-ports fd) )
(begin
(##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
(yield)
(loop) ) ) ) ) )
(define (tcp-accept-ready? tcpl)
(##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
(let ([f (##net#select (##sys#slot tcpl 1))])
(when (eq? -1 f)
(##sys#update-errno)
(##sys#signal-hook
#:network-error 'tcp-accept-ready? (##sys#string-append "can not check socket for input - " strerror)
tcpl) )
(eq? 1 f) ) )
(define (tcp-connect host . more)
(let ([port (:optional more #f)])
(##sys#check-string host)
(unless port
(set!-values (host port) (##net#parse-host host "tcp"))
(unless port (##sys#signal-hook #:network-error 'tcp-connect "no port specified" host)) )
(##sys#check-exact port)
(let ([addr (make-string _sockaddr_in_size)]
[s (##net#socket _af_inet _sock_stream 0)] )
(define (fail)
(##net#close s)
(##sys#update-errno)
(##sys#signal-hook
#:network-error 'tcp-connect (##sys#string-append "can not connect to socket - " strerror)
host port) )
(when (eq? -1 s)
(##sys#update-errno)
(##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "can not create socket - " strerror) host port) )
(unless (##net#gethostaddr addr host port)
(##sys#signal-hook #:network-error 'tcp-connect "can not find host address" host) )
(unless (##net#make-nonblocking s)
(##sys#update-errno)
(##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "fcntl() failed - " strerror)) )
(when (eq? -1 (##net#connect s addr _sockaddr_in_size))
(if (eq? errno _einprogress)
(let loop ()
(let ([f (##net#select-write s)])
(when (eq? f -1) (fail))
(unless (eq? f 1)
;(##sys#thread-block-for-i/o! ##sys#current-thread s #t)
(yield)
(loop) ) ) )
(fail) ) )
(##net#io-ports s) ) ) )
(define (##sys#tcp-port->fileno p)
(##sys#slot (##sys#tcp-port-data p) 0) )
(define (##sys#tcp-port-data p)
(##sys#check-port p)
(let ([d (##sys#port-data p)])
(if d
(##sys#slot d 0)
(##sys#signal-hook #:type-error "bad argument type - not a TCP port - " p) ) ) )
(define (tcp-addresses p)
(let ([fd (##sys#tcp-port->fileno p)])
(values
(or (##net#getsockname fd)
(##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "can not compute local address - " strerror) p) )
(or (##net#getpeername fd)
(##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "can not compute remote address - " strerror) p) ) ) ) )
(define (tcp-listener-port tcpl)
(##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
(let* ([fd (##sys#slot tcpl 1)]
[port (##net#getsockport fd)] )
(when (eq? -1 port)
(##sys#signal-hook
#:network-error 'tcp-listener-port (##sys#string-append "can not obtain listener port - " strerror)
tcpl fd) )
port) )
(define (tcp-abandon-port p)
(##sys#setislot
(##sys#tcp-port-data p)
(if (##sys#slot p 1) 2 1)
#t) )
(define (tcp-listener-fileno l)
(##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
(##sys#slot l 1) )
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
