~ 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 recv (foreign-lambda int "recv" int scheme-pointer int int))182(define shutdown (foreign-lambda int "shutdown" int int))183(define connect (foreign-lambda int "connect" int scheme-pointer int))184(define check-fd-ready (foreign-lambda int "C_check_fd_ready" int))185(define set-socket-options (foreign-lambda int "C_set_socket_options" int))186187(define send188 (foreign-lambda*189 int ((int s) (scheme-pointer msg) (int offset) (int len) (int flags))190 "C_return(send(s, (char *)msg+offset, len, flags));"))191192(define getsockname193 (foreign-lambda* c-string ((int s))194 "struct sockaddr_in sa;"195 "unsigned char *ptr;"196 "int len = sizeof(struct sockaddr_in);"197 "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)&len) != 0) C_return(NULL);"198 "ptr = (unsigned char *)&sa.sin_addr;"199 "C_snprintf(addr_buffer, sizeof(addr_buffer), \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"200 "C_return(addr_buffer);") )201202(define getsockport203 (foreign-lambda* int ((int s))204 "struct sockaddr_in sa;"205 "int len = sizeof(struct sockaddr_in);"206 "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) C_return(-1);"207 "else C_return(ntohs(sa.sin_port));") )208209(define getpeerport210 (foreign-lambda* int ((int s))211 "struct sockaddr_in sa;"212 "int len = sizeof(struct sockaddr_in);"213 "if(getpeername(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) C_return(-1);"214 "else C_return(ntohs(sa.sin_port));") )215216(define getpeername217 (foreign-lambda* c-string ((int s))218 "struct sockaddr_in sa;"219 "unsigned char *ptr;"220 "unsigned int len = sizeof(struct sockaddr_in);"221 "if(getpeername(s, (struct sockaddr *)&sa, ((socklen_t *)&len)) != 0) C_return(NULL);"222 "ptr = (unsigned char *)&sa.sin_addr;"223 "C_snprintf(addr_buffer, sizeof(addr_buffer), \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"224 "C_return(addr_buffer);") )225226(define startup227 (foreign-lambda* bool () #<<EOF228#ifdef _WIN32229 C_return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);230#else231 signal(SIGPIPE, SIG_IGN);232 C_return(1);233#endif234EOF235) )236237(unless (startup)238 (##sys#signal-hook #:network-error "cannot initialize Winsock") )239240(define getservbyname241 (foreign-lambda* int ((c-string serv) (c-string proto))242 "struct servent *se;243 if((se = getservbyname(serv, proto)) == NULL) C_return(0);244 else C_return(ntohs(se->s_port));") )245246(define gethostaddr247 (foreign-lambda* bool ((nonnull-scheme-pointer saddr) (c-string host) (unsigned-short port))248 "struct hostent *he = gethostbyname(host);"249 "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"250 "if(he == NULL) C_return(0);"251 "memset(addr, 0, sizeof(struct sockaddr_in));"252 "addr->sin_family = AF_INET;"253 "addr->sin_port = htons((short)port);"254 "addr->sin_addr = *((struct in_addr *)he->h_addr);"255 "C_return(1);") )256257(define-syntax network-error258 (syntax-rules ()259 ((_ loc msg . args)260 (network-error/code loc (last-error-code) msg . args))))261262(define-syntax network-error/close263 (syntax-rules ()264 ((_ loc msg socket . args)265 (let ((error-code (last-error-code)))266 (close socket)267 (network-error/code loc error-code msg socket . args)))))268269(define-syntax network-error/code270 (syntax-rules ()271 ((_ loc error-code msg . args)272 (##sys#signal-hook #:network-error loc273 (string-append (string-append msg " - ")274 (error-code->message error-code))275 . args))))276277(define parse-host278 (let ((substring substring))279 (lambda (host proto)280 (let ((len (string-length host)))281 (let loop ((i 0))282 (if (fx>= i len)283 (values host #f)284 (let ((c (string-ref host i)))285 (if (char=? c #\:)286 (values287 (substring host (fx+ i 1) len)288 (let* ((s (substring host 0 i))289 (p (getservbyname s proto)))290 (when (eq? 0 p)291 (network-error 'tcp-connect "cannot compute port from service" s) )292 p) )293 (loop (fx+ i 1)) ) ) ) ) ) ) ) )294295(define fresh-addr296 (foreign-lambda* void ((nonnull-scheme-pointer saddr) (unsigned-short port))297 "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"298 "memset(addr, 0, sizeof(struct sockaddr_in));"299 "addr->sin_family = AF_INET;"300 "addr->sin_port = htons(port);"301 "addr->sin_addr.s_addr = htonl(INADDR_ANY);") )302303(define (bind-socket style host port)304 (let ((addr (make-string _sockaddr_in_size)))305 (if host306 (unless (gethostaddr addr host port)307 (##sys#signal-hook308 #:network-error 'tcp-listen309 "getting listener host IP failed" host port) )310 (fresh-addr addr port) )311 (let ((s (socket _af_inet style 0)))312 (when (eq? _invalid_socket s)313 (##sys#error "cannot create socket") )314 ;; PLT makes this an optional arg to tcp-listen. Should we as well?315 (when (eq? _socket_error (set-socket-options s))316 (network-error 'tcp-listen "error while setting up socket" s) )317 (when (eq? _socket_error (bind s addr _sockaddr_in_size))318 (network-error/close 'tcp-listen "cannot bind to socket" s host port) )319 s)) )320321(define-constant default-backlog 100)322323(define (tcp-listen port #!optional (backlog default-backlog) host)324 (##sys#check-fixnum port)325 (when (or (fx< port 0) (fx> port 65535))326 (##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) )327 (##sys#check-fixnum backlog)328 (let ((s (bind-socket _sock_stream host port)))329 (when (eq? _socket_error (listen s backlog))330 (network-error/close 'tcp-listen "cannot listen on socket" s port) )331 (##sys#make-structure 'tcp-listener s) ) )332333(define (tcp-listener? x)334 (and (##core#inline "C_blockp" x)335 (##sys#structure? x 'tcp-listener) ) )336337(define (tcp-close tcpl)338 (##sys#check-structure tcpl 'tcp-listener)339 (let ((s (##sys#slot tcpl 1)))340 (when (eq? _socket_error (close s))341 (network-error 'tcp-close "cannot close TCP socket" tcpl) ) ) )342343(define-constant +input-buffer-size+ 1024)344(define-constant +output-chunk-size+ 8192)345346(define tcp-buffer-size (make-parameter #f))347(define tcp-read-timeout)348(define tcp-write-timeout)349(define tcp-connect-timeout)350(define tcp-accept-timeout)351352(let ()353 (define ((check loc) x)354 (when x (##sys#check-fixnum x loc))355 x)356 (define minute (fx* 60 1000))357 (set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout)))358 (set! tcp-write-timeout (make-parameter minute (check 'tcp-write-timeout)))359 (set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout)))360 (set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )361362(define io-ports363 (let ((tbs tcp-buffer-size))364 (lambda (loc fd enc)365 (unless (##core#inline "make_socket_nonblocking" fd)366 (network-error/close loc "cannot create TCP ports" fd) )367 (let* ((buf (##sys#make-bytevector +input-buffer-size+))368 (data (vector fd #f #f buf 0))369 (buflen 0)370 (bufindex 0) ; also used as outbuf-position371 (iclosed #f)372 (oclosed #f)373 (outbufsize (tbs))374 (outbuf (and outbufsize375 (fx> outbufsize 0)376 (##sys#make-bytevector outbufsize)))377 (read-input378 (lambda ()379 (let* ((tmr (tcp-read-timeout))380 (dlr (and tmr (+ (current-process-milliseconds) tmr))))381 (let loop ()382 (let ((n (recv fd buf +input-buffer-size+ 0)))383 (cond ((eq? _socket_error n)384 (cond ((retry?)385 (when dlr386 (##sys#thread-block-for-timeout!387 ##sys#current-thread dlr) )388 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)389 (##sys#thread-yield!)390 (when (##sys#slot ##sys#current-thread 13)391 (##sys#signal-hook392 #:network-timeout-error393 "read operation timed out" tmr fd) )394 (loop) )395 ((interrupted?)396 (##sys#dispatch-interrupt loop))397 (else398 (network-error #f "cannot read from socket" fd) ) ) )399 (else400 (set! buflen n)401 (##sys#setislot data 4 n)402 (set! bufindex 0) ) ) ) )) ) )403 (inport #f)404 (in405 (make-input-port406 (lambda () ; read407 (when (fx>= bufindex buflen)408 (read-input))409 (if (fx>= bufindex buflen)410 #!eof411 (##sys#decode-buffer buf bufindex 1 (##sys#slot inport 15)412 (lambda (buf start n)413 (set! bufindex (fx+ bufindex n))414 (##core#inline "C_utf_decode" buf start)))))415 (lambda () ; char-ready?416 (or (fx< bufindex buflen)417 ;; XXX: This "knows" that check_fd_ready is418 ;; implemented using a winsock2 call on Windows419 (let ((f (check-fd-ready fd)))420 (when (eq? _socket_error f)421 (network-error #f "cannot check socket for input" fd) )422 (eq? f 1) ) ) )423 (lambda () ; close424 (unless iclosed425 (set! iclosed #t)426 (unless (##sys#slot data 1) (shutdown fd _shut_rd))427 (when (and oclosed (eq? _socket_error (close fd)))428 (network-error #f "cannot close socket input port" fd) ) ) )429 peek-char:430 (lambda () ; peek-char431 (when (fx>= bufindex buflen)432 (read-input))433 (if (fx>= bufindex buflen)434 #!eof435 (##sys#decode-buffer buf bufindex 1 (##sys#slot inport 15)436 (lambda (buf start n)437 (##core#inline "C_utf_decode" buf start)))))438 read-bytevector:439 (lambda (p n dest start) ; read-bytevector!440 (let loop ((n n) (m 0) (start start))441 (cond ((eq? n 0) m)442 ((fx< bufindex buflen)443 (let* ((rest (fx- buflen bufindex))444 (n2 (if (fx< n rest) n rest)))445 (##core#inline "C_copy_memory_with_offset" dest buf start446 bufindex n2)447 (set! bufindex (fx+ bufindex n2))448 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )449 (else450 (read-input)451 (if (eq? buflen 0)452 m453 (loop n m start) ) ) ) ) )454 read-line:455 (lambda (p limit) ; read-line456 (when (fx>= bufindex buflen)457 (read-input))458 (if (fx>= bufindex buflen)459 #!eof460 (let ((limit (or limit (fx- most-positive-fixnum bufindex))))461 (receive (next line full-line?)462 (##sys#scan-buffer-line463 buf464 (fxmin buflen (fx+ bufindex limit))465 bufindex466 (lambda (pos)467 (let ((nbytes (fx- pos bufindex)))468 (cond ((fx>= nbytes limit)469 (values #f pos #f))470 (else (read-input)471 (set! limit (fx- limit nbytes))472 (if (fx< bufindex buflen)473 (values buf bufindex474 (fxmin buflen475 (fx+ bufindex limit)))476 (values #f bufindex #f))))))477 (##sys#slot inport 15))478 ;; Update row & column position479 (if full-line?480 (begin481 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))482 (##sys#setislot p 5 0))483 (##sys#setislot p 5 (fx+ (##sys#slot p 5)484 (string-length line))))485 (set! bufindex next)486 line) )) )487 read-buffered:488 (lambda (p) ; read-buffered489 (if (fx>= bufindex buflen)490 ""491 (let ((str (##sys#buffer->string/encoding buf bufindex buflen (##sys#slot inport 15))))492 (set! bufindex buflen)493 str)))494 ) )495 (outport #f)496 (output-to-socket497 (lambda (bv n)498 (let ((tmw (tcp-write-timeout)))499 (##sys#encode-buffer500 bv 0 n (##sys#slot outport 15)501 (lambda (buf start len)502 (let loop ((len len)503 (offset start)504 (dlw (and tmw (+ (current-process-milliseconds) tmw))))505 (let* ((count (fxmin +output-chunk-size+ len))506 (n (send fd buf offset count 0)))507 (cond ((eq? _socket_error n)508 (cond ((retry?)509 (when dlw510 (##sys#thread-block-for-timeout! ##sys#current-thread dlw) )511 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)512 (##sys#thread-yield!)513 (when (##sys#slot ##sys#current-thread 13)514 (##sys#signal-hook #:network-timeout-error515 "write operation timed out" tmw fd) )516 (loop len offset dlw) )517 ((interrupted?)518 (##sys#dispatch-interrupt519 (cut loop len offset dlw)))520 (else521 (network-error #f "cannot write to socket" fd) ) ) )522 ((fx< n len)523 (loop (fx- len n) (fx+ offset n)524 (if (fx= n 0)525 tmw526 ;; If we wrote *something*, reset timeout527 (and tmw (+ (current-process-milliseconds) tmw)) )) ) ) ) )) ) )))528 (add-to-buf529 (lambda (bv n)530 (let loop ((n n) (p 0))531 (unless (eq? n 0)532 (let ((newindex (fx+ bufindex n)))533 (cond ((fx> newindex outbufsize)534 (let ((part (fx- outbufsize bufindex)))535 (##core#inline "C_copy_memory_with_offset" outbuf bv536 bufindex p part)537 (output-to-socket outbuf outbufsize)538 (set! bufindex 0)539 (loop (fx- n part) (fx+ p part))))540 (else541 (##core#inline "C_copy_memory_with_offset" outbuf bv542 bufindex p n)543 (set! bufindex (fx+ bufindex n)))))))))544 (outclass545 (vector546 #f ; read-char547 #f ; peek-char548 (lambda (p c) ; write-char549 (let* ((bv (##sys#make-bytevector 4))550 (n (##core#inline "C_utf_insert" bv 0 c)))551 (if outbuf552 (add-to-buf bv n)553 (output-to-socket bv n))))554 (lambda (p bv from to) ; write-bytevector555 (let ((n (fx- to from)))556 (when (fx> n 0)557 (if outbuf558 (add-to-buf bv n)559 (output-to-socket bv n)))))560 (lambda (p d) ; close561 (unless oclosed562 (set! oclosed #t)563 (when (and outbuf (fx> bufindex 0))564 (output-to-socket outbuf bufindex)565 (set! bufindex 0))566 (unless (##sys#slot data 2) (shutdown fd _shut_wr))567 (when (and iclosed (eq? _socket_error (close fd)))568 (network-error #f "cannot close socket output port" fd) ) ) )569 (lambda (p) ; flush570 (when (and outbuf (fx> bufindex 0))571 (output-to-socket outbuf bufindex)572 (set! bufindex 0) ) )573 #f ; char-ready?574 #f ; read-bytevector?575 #f ; read-line576 #f)) ; read-buffered577 (out (##sys#make-port 2 outclass "(tcp)" 'socket)))578 (##sys#setslot in 3 "(tcp)")579 (##sys#setslot in 7 'socket)580 (##sys#set-port-data! in data)581 (##sys#set-port-data! out data)582 (set! inport in)583 (set! outport out)584 (##sys#setslot in 15 enc)585 (##sys#setslot out 15 enc)586 (values in out) ) ) ) )587588(define (tcp-accept tcpl #!optional (enc 'utf-8))589 (##sys#check-structure tcpl 'tcp-listener)590 (let* ((fd (##sys#slot tcpl 1))591 (tma (tcp-accept-timeout))592 (dla (and tma (+ tma (current-process-milliseconds)))))593 (let loop ()594 (when dla595 (##sys#thread-block-for-timeout! ##sys#current-thread dla) )596 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)597 (##sys#thread-yield!)598 (if (##sys#slot ##sys#current-thread 13)599 (##sys#signal-hook600 #:network-timeout-error601 'tcp-accept602 "accept operation timed out" tma fd) )603 (let ((fd (accept fd #f #f)))604 (cond ((not (eq? _invalid_socket fd))605 (io-ports 'tcp-accept fd enc))606 ((interrupted?)607 (##sys#dispatch-interrupt loop))608 (else609 (network-error 'tcp-accept "could not accept from listener" tcpl)))) ) ) )610611(define (tcp-accept-ready? tcpl)612 (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)613 ;; XXX: This "knows" that check_fd_ready is implemented using a winsock2 call614 (let ((f (check-fd-ready (##sys#slot tcpl 1))))615 (when (eq? _socket_error f)616 (network-error 'tcp-accept-ready? "cannot check socket for input" tcpl) )617 (eq? 1 f) ) )618619(define get-socket-error620 (foreign-lambda* int ((int socket))621 "int err, optlen;"622 "optlen = sizeof(err);"623 "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == SOCKET_ERROR)"624 " C_return(SOCKET_ERROR);"625 "C_return(err);"))626627(define (tcp-connect host #!optional port (enc 'utf-8))628 (let* ((tmc (tcp-connect-timeout))629 (dlc (and tmc (+ (current-process-milliseconds) tmc)))630 (addr (make-string _sockaddr_in_size)))631 (##sys#check-string host)632 (unless port633 (set!-values (host port) (parse-host host "tcp"))634 (unless port (##sys#signal-hook #:domain-error 'tcp-connect "no port specified" host)) )635 (##sys#check-fixnum port)636 (unless (gethostaddr addr host port)637 (##sys#signal-hook #:network-error 'tcp-connect "cannot find host address" host) )638 (let ((s (socket _af_inet _sock_stream 0)))639 (when (eq? _invalid_socket s)640 (network-error 'tcp-connect "cannot create socket" host port) )641 (when (eq? _socket_error (set-socket-options s))642 (network-error/close 'tcp-connect "error while setting up socket" s) )643 (unless (##core#inline "make_socket_nonblocking" s)644 (network-error/close 'tcp-connect "fcntl() failed" s) )645 (let loop ()646 (when (eq? _socket_error (connect s addr _sockaddr_in_size))647 (cond ((in-progress?) ; Wait till it's available via select/poll648 (when dlc649 (##sys#thread-block-for-timeout! ##sys#current-thread dlc))650 (##sys#thread-block-for-i/o! ##sys#current-thread s #:output)651 (##sys#thread-yield!)) ; Don't loop: it's connected now652 ((interrupted?)653 (##sys#dispatch-interrupt loop))654 (else655 (network-error/close656 'tcp-connect "cannot connect to socket" s host port)))))657 (let ((err (get-socket-error s)))658 (cond ((eq? _socket_error err)659 (network-error/close 'tcp-connect "getsockopt() failed" s))660 ((fx> err 0)661 (close s)662 (network-error/code 'tcp-connect err "cannot create socket"))))663 (io-ports 'tcp-connect s enc))) )664665(define (tcp-port->fileno p loc)666 (let ((data (##sys#port-data p)))667 (if (vector? data) ; a meagre test, but better than nothing668 (##sys#slot data 0)669 (error loc "argument does not appear to be a TCP port" p))))670671(define (tcp-addresses p)672 (##sys#check-open-port p 'tcp-addresses)673 (let ((fd (tcp-port->fileno p 'tcp-addresses)))674 (values675 (or (getsockname fd)676 (network-error 'tcp-addresses "cannot compute local address" p) )677 (or (getpeername fd)678 (network-error 'tcp-addresses "cannot compute remote address" p) ) ) ) )679680(define (tcp-port-numbers p)681 (##sys#check-open-port p 'tcp-port-numbers)682 (let ((fd (tcp-port->fileno p 'tcp-port-numbers)))683 (let ((sp (getsockport fd))684 (pp (getpeerport fd)))685 (when (eq? -1 sp)686 (network-error 'tcp-port-numbers "cannot compute local port" p) )687 (when (eq? -1 pp)688 (network-error 'tcp-port-numbers "cannot compute remote port" p) )689 (values sp pp))))690691(define (tcp-listener-port tcpl)692 (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)693 (let* ((fd (##sys#slot tcpl 1))694 (port (getsockport fd)))695 (when (eq? -1 port)696 (network-error 'tcp-listener-port "cannot obtain listener port" tcpl fd) )697 port) )698699(define (tcp-abandon-port p)700 (##sys#check-open-port p 'tcp-abandon-port)701 (##sys#setislot (##sys#port-data p) (##sys#slot p 1) #t))702703(define (tcp-listener-fileno l)704 (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)705 (##sys#slot l 1) )706707)