~ chicken-core (master) /tcp.scm
Trap1;;;; tcp.scm - Networking stuff2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; 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 promote15; 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 EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728(declare29 (unit tcp)30 (uses port scheduler)31 (disable-interrupts) ; Avoid race conditions around errno/WSAGetLastError32 (foreign-declare #<<EOF33#ifdef _WIN3234# include <winsock2.h>35# include <ws2tcpip.h>36/* Beware: winsock2.h must come BEFORE windows.h */37# define socklen_t int38static WSADATA wsa;39# ifndef SHUT_RD40# define SHUT_RD SD_RECEIVE41# endif42# ifndef SHUT_WR43# define SHUT_WR SD_SEND44# endif4546# define typecorrect_getsockopt(socket, level, optname, optval, optlen) \47 getsockopt(socket, level, optname, (char *)optval, optlen)4849static C_word make_socket_nonblocking (C_word sock) {50 int fd = C_unfix(sock);51 C_return(C_mk_bool(ioctlsocket(fd, FIONBIO, (void *)&fd) != SOCKET_ERROR)) ;52}5354/* This is a bit of a hack, but it keeps things simple */55static C_char *last_wsa_errorstring = NULL;5657static char *errormsg_from_code(int code) {58 int bufsize;59 if (last_wsa_errorstring != NULL) {60 LocalFree(last_wsa_errorstring);61 last_wsa_errorstring = NULL;62 }63 bufsize = FormatMessage(64 FORMAT_MESSAGE_ALLOCATE_BUFFER |65 FORMAT_MESSAGE_FROM_SYSTEM |66 FORMAT_MESSAGE_IGNORE_INSERTS,67 NULL, code, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),68 (LPTSTR) &last_wsa_errorstring, 0, NULL);69 if (bufsize == 0) return "ERROR WHILE FETCHING ERROR";70 return last_wsa_errorstring;71}7273# define get_last_socket_error() WSAGetLastError()74# define should_retry_call() (WSAGetLastError() == WSAEWOULDBLOCK)75/* Not EINPROGRESS in winsock. Nonblocking connect returns EWOULDBLOCK... */76# define call_in_progress() (WSAGetLastError() == WSAEWOULDBLOCK)77# define call_was_interrupted() (WSAGetLastError() == WSAEINTR) /* ? */7879#else80# include <errno.h>81# include <fcntl.h>82# include <sys/socket.h>83# include <sys/time.h>84# include <netinet/in.h>85# include <netdb.h>86# include <signal.h>87# define closesocket close88# define INVALID_SOCKET -189# define SOCKET_ERROR -190# define typecorrect_getsockopt getsockopt9192static C_word make_socket_nonblocking (C_word sock) {93 int fd = C_unfix(sock);94 int val = fcntl(fd, F_GETFL, 0);95 if(val == -1) C_return(C_SCHEME_FALSE);96 C_return(C_mk_bool(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1));97}9899# define get_last_socket_error() errno100# define errormsg_from_code(e) strerror(e)101102# define should_retry_call() (errno == EAGAIN || errno == EWOULDBLOCK)103# define call_was_interrupted() (errno == EINTR)104# define call_in_progress() (errno == EINPROGRESS)105#endif106107#ifdef ECOS108#include <sys/sockio.h>109#endif110111#ifndef h_addr112# define h_addr h_addr_list[ 0 ]113#endif114115static char addr_buffer[ 20 ];116117static int C_set_socket_options(int socket)118{119 int yes = 1;120 int r;121122 r = setsockopt(socket, SOL_SOCKET, SO_REUSEADDR, (const char *)&yes, sizeof(int));123124 if(r != 0) return r;125126#ifdef SO_NOSIGPIPE127 /*128 * Avoid SIGPIPE (iOS uses *only* SIGPIPE otherwise, not returning EPIPE).129 * For consistency we do this everywhere the option is supported.130 */131 r = setsockopt(socket, SOL_SOCKET, SO_NOSIGPIPE, (const char *)&yes, sizeof(int));132#endif133134 return r;135}136137EOF138) )139140(module chicken.tcp141 (tcp-close tcp-listen tcp-connect tcp-accept tcp-accept-ready?142 tcp-listener? tcp-addresses tcp-abandon-port tcp-listener-port143 tcp-listener-fileno tcp-port-numbers tcp-buffer-size tcp-read-timeout144 tcp-write-timeout tcp-accept-timeout tcp-connect-timeout)145146(import scheme147 chicken.base148 chicken.fixnum149 chicken.foreign150 chicken.port151 chicken.time)152(import (only (scheme base) make-parameter))153154(include "common-declarations.scm")155156157(define-foreign-type sockaddr* (pointer "struct sockaddr"))158(define-foreign-type sockaddr_in* (pointer "struct sockaddr_in"))159160(define-foreign-variable _af_inet int "AF_INET")161(define-foreign-variable _sock_stream int "SOCK_STREAM")162(define-foreign-variable _sock_dgram int "SOCK_DGRAM")163(define-foreign-variable _sockaddr_size int "sizeof(struct sockaddr)")164(define-foreign-variable _sockaddr_in_size int "sizeof(struct sockaddr_in)")165(define-foreign-variable _shut_rd int "SHUT_RD")166(define-foreign-variable _shut_wr int "SHUT_WR")167(define-foreign-variable _ipproto_tcp int "IPPROTO_TCP")168(define-foreign-variable _invalid_socket int "INVALID_SOCKET")169(define-foreign-variable _socket_error int "SOCKET_ERROR")170171(define last-error-code (foreign-lambda int "get_last_socket_error"))172(define error-code->message (foreign-lambda c-string "errormsg_from_code" int))173(define retry? (foreign-lambda bool "should_retry_call"))174(define in-progress? (foreign-lambda bool "call_in_progress"))175(define interrupted? (foreign-lambda bool "call_was_interrupted"))176(define socket (foreign-lambda int "socket" int int int))177(define bind (foreign-lambda int "bind" int scheme-pointer int))178(define listen (foreign-lambda int "listen" int int))179(define accept (foreign-lambda int "accept" int c-pointer c-pointer))180(define close (foreign-lambda int "closesocket" int))181(define shutdown (foreign-lambda int "shutdown" int int))182(define connect (foreign-lambda int "connect" int scheme-pointer int))183(define check-fd-ready (foreign-lambda int "C_check_fd_ready" int))184(define set-socket-options (foreign-lambda int "C_set_socket_options" int))185186(define recv187 (foreign-lambda* int ((int s) (scheme-pointer buf) (int offset) (int len))188 "C_return(recv(s, (char *)buf+offset, len, 0));"))189190(define send191 (foreign-lambda*192 int ((int s) (scheme-pointer msg) (int offset) (int len) (int flags))193 "C_return(send(s, (char *)msg+offset, len, flags));"))194195(define getsockname196 (foreign-lambda* c-string ((int s))197 "struct sockaddr_in sa;"198 "unsigned char *ptr;"199 "int len = sizeof(struct sockaddr_in);"200 "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)&len) != 0) C_return(NULL);"201 "ptr = (unsigned char *)&sa.sin_addr;"202 "C_snprintf(addr_buffer, sizeof(addr_buffer), \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"203 "C_return(addr_buffer);") )204205(define getsockport206 (foreign-lambda* int ((int s))207 "struct sockaddr_in sa;"208 "int len = sizeof(struct sockaddr_in);"209 "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) C_return(-1);"210 "else C_return(ntohs(sa.sin_port));") )211212(define getpeerport213 (foreign-lambda* int ((int s))214 "struct sockaddr_in sa;"215 "int len = sizeof(struct sockaddr_in);"216 "if(getpeername(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) C_return(-1);"217 "else C_return(ntohs(sa.sin_port));") )218219(define getpeername220 (foreign-lambda* c-string ((int s))221 "struct sockaddr_in sa;"222 "unsigned char *ptr;"223 "unsigned int len = sizeof(struct sockaddr_in);"224 "if(getpeername(s, (struct sockaddr *)&sa, ((socklen_t *)&len)) != 0) C_return(NULL);"225 "ptr = (unsigned char *)&sa.sin_addr;"226 "C_snprintf(addr_buffer, sizeof(addr_buffer), \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"227 "C_return(addr_buffer);") )228229(define startup230 (foreign-lambda* bool () #<<EOF231#ifdef _WIN32232 C_return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);233#else234 signal(SIGPIPE, SIG_IGN);235 C_return(1);236#endif237EOF238) )239240(unless (startup)241 (##sys#signal-hook #:network-error "cannot initialize Winsock") )242243(define getservbyname244 (foreign-lambda* int ((c-string serv) (c-string proto))245 "struct servent *se;246 if((se = getservbyname(serv, proto)) == NULL) C_return(0);247 else C_return(ntohs(se->s_port));") )248249(define gethostaddr250 (foreign-lambda* bool ((nonnull-scheme-pointer saddr) (c-string host) (unsigned-short port))251 "struct hostent *he = gethostbyname(host);"252 "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"253 "if(he == NULL) C_return(0);"254 "memset(addr, 0, sizeof(struct sockaddr_in));"255 "addr->sin_family = AF_INET;"256 "addr->sin_port = htons((short)port);"257 "addr->sin_addr = *((struct in_addr *)he->h_addr);"258 "C_return(1);") )259260(define-syntax network-error261 (syntax-rules ()262 ((_ loc msg . args)263 (network-error/code loc (last-error-code) msg . args))))264265(define-syntax network-error/close266 (syntax-rules ()267 ((_ loc msg socket . args)268 (let ((error-code (last-error-code)))269 (close socket)270 (network-error/code loc error-code msg socket . args)))))271272(define-syntax network-error/code273 (syntax-rules ()274 ((_ loc error-code msg . args)275 (##sys#signal-hook #:network-error loc276 (string-append (string-append msg " - ")277 (error-code->message error-code))278 . args))))279280(define parse-host281 (let ((substring substring))282 (lambda (host proto)283 (let ((len (string-length host)))284 (let loop ((i 0))285 (if (fx>= i len)286 (values host #f)287 (let ((c (string-ref host i)))288 (if (char=? c #\:)289 (values290 (substring host (fx+ i 1) len)291 (let* ((s (substring host 0 i))292 (p (getservbyname s proto)))293 (when (eq? 0 p)294 (network-error 'tcp-connect "cannot compute port from service" s) )295 p) )296 (loop (fx+ i 1)) ) ) ) ) ) ) ) )297298(define fresh-addr299 (foreign-lambda* void ((nonnull-scheme-pointer saddr) (unsigned-short port))300 "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"301 "memset(addr, 0, sizeof(struct sockaddr_in));"302 "addr->sin_family = AF_INET;"303 "addr->sin_port = htons(port);"304 "addr->sin_addr.s_addr = htonl(INADDR_ANY);") )305306(define (bind-socket style host port)307 (let ((addr (##sys#make-bytevector _sockaddr_in_size)))308 (if host309 (unless (gethostaddr addr host port)310 (##sys#signal-hook311 #:network-error 'tcp-listen312 "getting listener host IP failed" host port) )313 (fresh-addr addr port) )314 (let ((s (socket _af_inet style 0)))315 (when (eq? _invalid_socket s)316 (##sys#error "cannot create socket") )317 ;; PLT makes this an optional arg to tcp-listen. Should we as well?318 (when (eq? _socket_error (set-socket-options s))319 (network-error 'tcp-listen "error while setting up socket" s) )320 (when (eq? _socket_error (bind s addr _sockaddr_in_size))321 (network-error/close 'tcp-listen "cannot bind to socket" s host port) )322 s)) )323324(define-constant default-backlog 100)325326(define (tcp-listen port #!optional (backlog default-backlog) host)327 (##sys#check-fixnum port)328 (when (or (fx< port 0) (fx> port 65535))329 (##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) )330 (##sys#check-fixnum backlog)331 (let ((s (bind-socket _sock_stream host port)))332 (when (eq? _socket_error (listen s backlog))333 (network-error/close 'tcp-listen "cannot listen on socket" s port) )334 (##sys#make-structure 'tcp-listener s) ) )335336(define (tcp-listener? x)337 (and (##core#inline "C_blockp" x)338 (##sys#structure? x 'tcp-listener) ) )339340(define (tcp-close tcpl)341 (##sys#check-structure tcpl 'tcp-listener)342 (let ((s (##sys#slot tcpl 1)))343 (when (eq? _socket_error (close s))344 (network-error 'tcp-close "cannot close TCP socket" tcpl) ) ) )345346(define-constant +input-buffer-size+ 1024)347(define-constant +output-chunk-size+ 8192)348349(define tcp-buffer-size (make-parameter #f))350(define tcp-read-timeout)351(define tcp-write-timeout)352(define tcp-connect-timeout)353(define tcp-accept-timeout)354355(let ()356 (define ((check loc) x)357 (when x (##sys#check-fixnum x loc))358 x)359 (define minute (fx* 60 1000))360 (set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout)))361 (set! tcp-write-timeout (make-parameter minute (check 'tcp-write-timeout)))362 (set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout)))363 (set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )364365(define io-ports366 (let ((tbs tcp-buffer-size))367 (lambda (loc fd enc)368 (unless (##core#inline "make_socket_nonblocking" fd)369 (network-error/close loc "cannot create TCP ports" fd) )370 (let* ((buf (##sys#make-bytevector +input-buffer-size+))371 (data (vector fd #f #f buf 0))372 (buflen 0)373 (bufindex 0) ; also used as outbuf-position374 (iclosed #f)375 (oclosed #f)376 (outbufsize (tbs))377 (outbuf (and outbufsize378 (fx> outbufsize 0)379 (##sys#make-bytevector outbufsize)))380 (read-input381 (lambda (force off)382 (let* ((tmr (tcp-read-timeout))383 (dlr (and tmr (+ (current-process-milliseconds) tmr))))384 (let loop ()385 (let ((n (recv fd buf off (fx- +input-buffer-size+ off))))386 (cond ((eq? _socket_error n)387 (cond ((and (retry?) force)388 (when dlr389 (##sys#thread-block-for-timeout!390 ##sys#current-thread dlr) )391 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)392 (##sys#thread-yield!)393 (when (##sys#slot ##sys#current-thread 13)394 (##sys#signal-hook395 #:network-timeout-error396 "read operation timed out" tmr fd) )397 (loop) )398 ((retry?)399 (set! bufindex 0)400 (##sys#setislot data 4 off)401 (set! buflen off))402 ((interrupted?)403 (##sys#dispatch-interrupt loop))404 (else405 (network-error #f "cannot read from socket" fd) ) ) )406 (else407 (set! buflen (fx+ off n))408 (##sys#setislot data 4 (fx+ off n))409 (set! bufindex 0) ) ) ) )) ) )410 (inport #f)411 (in412 (make-input-port413 (lambda () ; read414 (when (fx>= bufindex buflen)415 (read-input #t 0))416 (if (fx>= bufindex buflen)417 #!eof418 (##sys#read-char/encoding419 inport (##sys#slot inport 15)420 (lambda (buf start len dec)421 (dec buf start len422 (lambda (buf start len)423 (##core#inline "C_utf_decode" buf start)))))))424 (lambda () ; char-ready?425 (or (fx< bufindex buflen)426 ;; XXX: This "knows" that check_fd_ready is427 ;; implemented using a winsock2 call on Windows428 (let ((f (check-fd-ready fd)))429 (when (eq? _socket_error f)430 (network-error #f "cannot check socket for input" fd) )431 (eq? f 1) ) ) )432 (lambda () ; close433 (unless iclosed434 (set! iclosed #t)435 (unless (##sys#slot data 1) (shutdown fd _shut_rd))436 (when (and oclosed (eq? _socket_error (close fd)))437 (network-error #f "cannot close socket input port" fd) ) ) )438 peek-char:439 (lambda () ; peek-char440 (let ((enc (##sys#slot inport 15)))441 (if (fx>= bufindex buflen)442 (read-input #t 0)443 (let ((n (##sys#scan-read-ahead enc444 (##core#inline "C_subbyte" buf bufindex)))445 (rest (fx- buflen bufindex)))446 (when (and n (fx> (fx+ n 1) rest))447 (##core#inline "C_copy_memory_with_offset"448 buf buf 0 bufindex rest)449 (read-input #f rest))))450 (if (fx< bufindex buflen)451 (##sys#decode-char buf enc bufindex)452 #!eof)))453 read-bytevector:454 (lambda (dest start end) ; read-bytevector!455 (let loop ((n (fx- end start)) (m 0) (start start))456 (cond ((eq? n 0) m)457 ((fx< bufindex buflen)458 (let* ((rest (fx- buflen bufindex))459 (n2 (if (fx< n rest) n rest)))460 (##core#inline "C_copy_memory_with_offset"461 dest buf start bufindex n2)462 (set! bufindex (fx+ bufindex n2))463 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )464 (else465 (read-input #t 0)466 (if (fx>= bufindex buflen)467 m468 (loop n m start) ) ) ) ) )469 read-line:470 (lambda (p limit) ; read-line471 (when (fx>= bufindex buflen)472 (read-input #t 0))473 (if (fx>= bufindex buflen)474 #!eof475 (let ((limit (or limit (fx- most-positive-fixnum bufindex))))476 (receive (next line full-line?)477 (##sys#scan-buffer-line478 buf479 (fxmin buflen (fx+ bufindex limit))480 bufindex481 (lambda (pos)482 (let ((nbytes (fx- pos bufindex)))483 (cond ((fx>= nbytes limit)484 (values #f pos #f))485 (else (read-input #t 0)486 (set! limit (fx- limit nbytes))487 (if (fx< bufindex buflen)488 (values buf bufindex489 (fxmin buflen490 (fx+ bufindex limit)))491 (values #f bufindex #f))))))492 (##sys#slot inport 15))493 ;; Update row & column position494 (if full-line?495 (begin496 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))497 (##sys#setislot p 5 0))498 (##sys#setislot p 5 (fx+ (##sys#slot p 5)499 (string-length line))))500 (set! bufindex next)501 line) )) )502 read-buffered:503 (lambda (p) ; read-buffered504 (if (fx>= bufindex buflen)505 ""506 (let ((str (##sys#buffer->string/encoding buf bufindex buflen (##sys#slot inport 15))))507 (set! bufindex buflen)508 str)))509 ) )510 (outport #f)511 (output-to-socket512 (lambda (bv n)513 (let ((tmw (tcp-write-timeout)))514 (##sys#encode-buffer515 bv 0 n (##sys#slot outport 15)516 (lambda (buf start len)517 (let loop ((len len)518 (offset start)519 (dlw (and tmw (+ (current-process-milliseconds) tmw))))520 (let* ((count (fxmin +output-chunk-size+ len))521 (n (send fd buf offset count 0)))522 (cond ((eq? _socket_error n)523 (cond ((retry?)524 (when dlw525 (##sys#thread-block-for-timeout! ##sys#current-thread dlw) )526 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)527 (##sys#thread-yield!)528 (when (##sys#slot ##sys#current-thread 13)529 (##sys#signal-hook #:network-timeout-error530 "write operation timed out" tmw fd) )531 (loop len offset dlw) )532 ((interrupted?)533 (##sys#dispatch-interrupt534 (cut loop len offset dlw)))535 (else536 (network-error #f "cannot write to socket" fd) ) ) )537 ((fx< n len)538 (loop (fx- len n) (fx+ offset n)539 (if (fx= n 0)540 tmw541 ;; If we wrote *something*, reset timeout542 (and tmw (+ (current-process-milliseconds) tmw)) )) ) ) ) )) ) )))543 (add-to-buf544 (lambda (bv n)545 (let loop ((n n) (p 0))546 (unless (eq? n 0)547 (let ((newindex (fx+ bufindex n)))548 (cond ((fx> newindex outbufsize)549 (let ((part (fx- outbufsize bufindex)))550 (##core#inline "C_copy_memory_with_offset" outbuf bv551 bufindex p part)552 (output-to-socket outbuf outbufsize)553 (set! bufindex 0)554 (loop (fx- n part) (fx+ p part))))555 (else556 (##core#inline "C_copy_memory_with_offset" outbuf bv557 bufindex p n)558 (set! bufindex (fx+ bufindex n)))))))))559 (outclass560 (vector561 #f ; read-char562 #f ; peek-char563 (lambda (p c) ; write-char564 (let* ((bv (##sys#make-bytevector 4))565 (n (##core#inline "C_utf_insert" bv 0 c)))566 (if outbuf567 (add-to-buf bv n)568 (output-to-socket bv n))))569 (lambda (p bv from to) ; write-bytevector570 (let ((n (fx- to from)))571 (when (fx> n 0)572 (if outbuf573 (add-to-buf bv n)574 (output-to-socket bv n)))))575 (lambda (p d) ; close576 (unless oclosed577 (set! oclosed #t)578 (when (and outbuf (fx> bufindex 0))579 (output-to-socket outbuf bufindex)580 (set! bufindex 0))581 (unless (##sys#slot data 2) (shutdown fd _shut_wr))582 (when (and iclosed (eq? _socket_error (close fd)))583 (network-error #f "cannot close socket output port" fd) ) ) )584 (lambda (p) ; flush585 (when (and outbuf (fx> bufindex 0))586 (output-to-socket outbuf bufindex)587 (set! bufindex 0) ) )588 #f ; char-ready?589 #f ; read-bytevector?590 #f ; read-line591 #f)) ; read-buffered592 (out (##sys#make-port 2 outclass "(tcp)" 'socket)))593 (##sys#setslot in 3 "(tcp)")594 (##sys#setslot in 7 'socket)595 (##sys#set-port-data! in data)596 (##sys#set-port-data! out data)597 (set! inport in)598 (set! outport out)599 (##sys#setslot in 15 enc)600 (##sys#setslot out 15 enc)601 (values in out) ) ) ) )602603(define (tcp-accept tcpl #!optional (enc 'utf-8))604 (##sys#check-structure tcpl 'tcp-listener)605 (let* ((fd (##sys#slot tcpl 1))606 (tma (tcp-accept-timeout))607 (dla (and tma (+ tma (current-process-milliseconds)))))608 (let loop ()609 (when dla610 (##sys#thread-block-for-timeout! ##sys#current-thread dla) )611 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)612 (##sys#thread-yield!)613 (if (##sys#slot ##sys#current-thread 13)614 (##sys#signal-hook615 #:network-timeout-error616 'tcp-accept617 "accept operation timed out" tma fd) )618 (let ((fd (accept fd #f #f)))619 (cond ((not (eq? _invalid_socket fd))620 (io-ports 'tcp-accept fd enc))621 ((interrupted?)622 (##sys#dispatch-interrupt loop))623 (else624 (network-error 'tcp-accept "could not accept from listener" tcpl)))) ) ) )625626(define (tcp-accept-ready? tcpl)627 (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)628 ;; XXX: This "knows" that check_fd_ready is implemented using a winsock2 call629 (let ((f (check-fd-ready (##sys#slot tcpl 1))))630 (when (eq? _socket_error f)631 (network-error 'tcp-accept-ready? "cannot check socket for input" tcpl) )632 (eq? 1 f) ) )633634(define get-socket-error635 (foreign-lambda* int ((int socket))636 "int err, optlen;"637 "optlen = sizeof(err);"638 "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == SOCKET_ERROR)"639 " C_return(SOCKET_ERROR);"640 "C_return(err);"))641642(define (tcp-connect host #!optional port (enc 'utf-8))643 (let* ((tmc (tcp-connect-timeout))644 (dlc (and tmc (+ (current-process-milliseconds) tmc)))645 (addr (##sys#make-bytevector _sockaddr_in_size)))646 (##sys#check-string host)647 (unless port648 (set!-values (host port) (parse-host host "tcp"))649 (unless port (##sys#signal-hook #:domain-error 'tcp-connect "no port specified" host)) )650 (##sys#check-fixnum port)651 (unless (gethostaddr addr host port)652 (##sys#signal-hook #:network-error 'tcp-connect "cannot find host address" host) )653 (let ((s (socket _af_inet _sock_stream 0)))654 (when (eq? _invalid_socket s)655 (network-error 'tcp-connect "cannot create socket" host port) )656 (when (eq? _socket_error (set-socket-options s))657 (network-error/close 'tcp-connect "error while setting up socket" s) )658 (unless (##core#inline "make_socket_nonblocking" s)659 (network-error/close 'tcp-connect "fcntl() failed" s) )660 (let loop ()661 (when (eq? _socket_error (connect s addr _sockaddr_in_size))662 (cond ((in-progress?) ; Wait till it's available via select/poll663 (when dlc664 (##sys#thread-block-for-timeout! ##sys#current-thread dlc))665 (##sys#thread-block-for-i/o! ##sys#current-thread s #:output)666 (##sys#thread-yield!)) ; Don't loop: it's connected now667 ((interrupted?)668 (##sys#dispatch-interrupt loop))669 (else670 (network-error/close671 'tcp-connect "cannot connect to socket" s host port)))))672 (let ((err (get-socket-error s)))673 (cond ((eq? _socket_error err)674 (network-error/close 'tcp-connect "getsockopt() failed" s))675 ((fx> err 0)676 (close s)677 (network-error/code 'tcp-connect err "cannot create socket"))))678 (io-ports 'tcp-connect s enc))) )679680(define (tcp-port->fileno p loc)681 (let ((data (##sys#port-data p)))682 (if (vector? data) ; a meagre test, but better than nothing683 (##sys#slot data 0)684 (error loc "argument does not appear to be a TCP port" p))))685686(define (tcp-addresses p)687 (##sys#check-open-port p 'tcp-addresses)688 (let ((fd (tcp-port->fileno p 'tcp-addresses)))689 (values690 (or (getsockname fd)691 (network-error 'tcp-addresses "cannot compute local address" p) )692 (or (getpeername fd)693 (network-error 'tcp-addresses "cannot compute remote address" p) ) ) ) )694695(define (tcp-port-numbers p)696 (##sys#check-open-port p 'tcp-port-numbers)697 (let ((fd (tcp-port->fileno p 'tcp-port-numbers)))698 (let ((sp (getsockport fd))699 (pp (getpeerport fd)))700 (when (eq? -1 sp)701 (network-error 'tcp-port-numbers "cannot compute local port" p) )702 (when (eq? -1 pp)703 (network-error 'tcp-port-numbers "cannot compute remote port" p) )704 (values sp pp))))705706(define (tcp-listener-port tcpl)707 (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)708 (let* ((fd (##sys#slot tcpl 1))709 (port (getsockport fd)))710 (when (eq? -1 port)711 (network-error 'tcp-listener-port "cannot obtain listener port" tcpl fd) )712 port) )713714(define (tcp-abandon-port p)715 (##sys#check-open-port p 'tcp-abandon-port)716 (##sys#setislot (##sys#port-data p) (##sys#slot p 1) #t))717718(define (tcp-listener-fileno l)719 (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)720 (##sys#slot l 1) )721722)