1;;;; tcp.scm - Networking stuff 2; 3; Copyright (c) 2008-2021, The CHICKEN Team 4; Copyright (c) 2000-2007, Felix L. Winkelmann 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 port scheduler) 31 (disable-interrupts) ; Avoid race conditions around errno/WSAGetLastError 32 (foreign-declare #<<EOF 33#ifdef _WIN32 34# include <winsock2.h> 35# include <ws2tcpip.h> 36/* Beware: winsock2.h must come BEFORE windows.h */ 37# define socklen_t int 38static WSADATA wsa; 39# ifndef SHUT_RD 40# define SHUT_RD SD_RECEIVE 41# endif 42# ifndef SHUT_WR 43# define SHUT_WR SD_SEND 44# endif 45 46# define typecorrect_getsockopt(socket, level, optname, optval, optlen) \ 47 getsockopt(socket, level, optname, (char *)optval, optlen) 48 49static 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} 53 54/* This is a bit of a hack, but it keeps things simple */ 55static C_TLS char *last_wsa_errorstring = NULL; 56 57static 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} 72 73# 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) /* ? */ 78 79#else 80# 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 close 88# define INVALID_SOCKET -1 89# define SOCKET_ERROR -1 90# define typecorrect_getsockopt getsockopt 91 92static 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} 98 99# define get_last_socket_error() errno 100# define errormsg_from_code(e) strerror(e) 101 102# define should_retry_call() (errno == EAGAIN || errno == EWOULDBLOCK) 103# define call_was_interrupted() (errno == EINTR) 104# define call_in_progress() (errno == EINPROGRESS) 105#endif 106 107#ifdef ECOS 108#include <sys/sockio.h> 109#endif 110 111#ifndef h_addr 112# define h_addr h_addr_list[ 0 ] 113#endif 114 115static char addr_buffer[ 20 ]; 116 117static int C_set_socket_options(int socket) 118{ 119 int yes = 1; 120 int r; 121 122 r = setsockopt(socket, SOL_SOCKET, SO_REUSEADDR, (const char *)&yes, sizeof(int)); 123 124 if(r != 0) return r; 125 126#ifdef SO_NOSIGPIPE 127 /* 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#endif 133 134 return r; 135} 136 137EOF 138) ) 139 140(module chicken.tcp 141 (tcp-close tcp-listen tcp-connect tcp-accept tcp-accept-ready? 142 tcp-listener? tcp-addresses tcp-abandon-port tcp-listener-port 143 tcp-listener-fileno tcp-port-numbers tcp-buffer-size tcp-read-timeout 144 tcp-write-timeout tcp-accept-timeout tcp-connect-timeout) 145 146(import scheme 147 chicken.base 148 chicken.fixnum 149 chicken.foreign 150 chicken.port 151 chicken.time) 152 153(include "common-declarations.scm") 154 155 156(define-foreign-type sockaddr* (pointer "struct sockaddr")) 157(define-foreign-type sockaddr_in* (pointer "struct sockaddr_in")) 158 159(define-foreign-variable _af_inet int "AF_INET") 160(define-foreign-variable _sock_stream int "SOCK_STREAM") 161(define-foreign-variable _sock_dgram int "SOCK_DGRAM") 162(define-foreign-variable _sockaddr_size int "sizeof(struct sockaddr)") 163(define-foreign-variable _sockaddr_in_size int "sizeof(struct sockaddr_in)") 164(define-foreign-variable _shut_rd int "SHUT_RD") 165(define-foreign-variable _shut_wr int "SHUT_WR") 166(define-foreign-variable _ipproto_tcp int "IPPROTO_TCP") 167(define-foreign-variable _invalid_socket int "INVALID_SOCKET") 168(define-foreign-variable _socket_error int "SOCKET_ERROR") 169 170(define last-error-code (foreign-lambda int "get_last_socket_error")) 171(define error-code->message (foreign-lambda c-string "errormsg_from_code" int)) 172(define retry? (foreign-lambda bool "should_retry_call")) 173(define in-progress? (foreign-lambda bool "call_in_progress")) 174(define interrupted? (foreign-lambda bool "call_was_interrupted")) 175(define socket (foreign-lambda int "socket" int int int)) 176(define bind (foreign-lambda int "bind" int scheme-pointer int)) 177(define listen (foreign-lambda int "listen" int int)) 178(define accept (foreign-lambda int "accept" int c-pointer c-pointer)) 179(define close (foreign-lambda int "closesocket" int)) 180(define recv (foreign-lambda int "recv" int scheme-pointer int 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)) 185 186(define send 187 (foreign-lambda* 188 int ((int s) (scheme-pointer msg) (int offset) (int len) (int flags)) 189 "C_return(send(s, (char *)msg+offset, len, flags));")) 190 191(define getsockname 192 (foreign-lambda* c-string ((int s)) 193 "struct sockaddr_in sa;" 194 "unsigned char *ptr;" 195 "int len = sizeof(struct sockaddr_in);" 196 "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)&len) != 0) C_return(NULL);" 197 "ptr = (unsigned char *)&sa.sin_addr;" 198 "C_snprintf(addr_buffer, sizeof(addr_buffer), \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);" 199 "C_return(addr_buffer);") ) 200 201(define getsockport 202 (foreign-lambda* int ((int s)) 203 "struct sockaddr_in sa;" 204 "int len = sizeof(struct sockaddr_in);" 205 "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) C_return(-1);" 206 "else C_return(ntohs(sa.sin_port));") ) 207 208(define getpeerport 209 (foreign-lambda* int ((int s)) 210 "struct sockaddr_in sa;" 211 "int len = sizeof(struct sockaddr_in);" 212 "if(getpeername(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) C_return(-1);" 213 "else C_return(ntohs(sa.sin_port));") ) 214 215(define getpeername 216 (foreign-lambda* c-string ((int s)) 217 "struct sockaddr_in sa;" 218 "unsigned char *ptr;" 219 "unsigned int len = sizeof(struct sockaddr_in);" 220 "if(getpeername(s, (struct sockaddr *)&sa, ((socklen_t *)&len)) != 0) C_return(NULL);" 221 "ptr = (unsigned char *)&sa.sin_addr;" 222 "C_snprintf(addr_buffer, sizeof(addr_buffer), \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);" 223 "C_return(addr_buffer);") ) 224 225(define startup 226 (foreign-lambda* bool () #<<EOF 227#ifdef _WIN32 228 C_return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0); 229#else 230 signal(SIGPIPE, SIG_IGN); 231 C_return(1); 232#endif 233EOF 234) ) 235 236(unless (startup) 237 (##sys#signal-hook #:network-error "cannot initialize Winsock") ) 238 239(define getservbyname 240 (foreign-lambda* int ((c-string serv) (c-string proto)) 241 "struct servent *se; 242 if((se = getservbyname(serv, proto)) == NULL) C_return(0); 243 else C_return(ntohs(se->s_port));") ) 244 245(define gethostaddr 246 (foreign-lambda* bool ((scheme-pointer saddr) (c-string host) (unsigned-short port)) 247 "struct hostent *he = gethostbyname(host);" 248 "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;" 249 "if(he == NULL) C_return(0);" 250 "memset(addr, 0, sizeof(struct sockaddr_in));" 251 "addr->sin_family = AF_INET;" 252 "addr->sin_port = htons((short)port);" 253 "addr->sin_addr = *((struct in_addr *)he->h_addr);" 254 "C_return(1);") ) 255 256(define-syntax network-error 257 (syntax-rules () 258 ((_ loc msg . args) 259 (network-error/code loc (last-error-code) msg . args)))) 260 261(define-syntax network-error/close 262 (syntax-rules () 263 ((_ loc msg socket . args) 264 (let ((error-code (last-error-code))) 265 (close socket) 266 (network-error/code loc error-code msg socket . args))))) 267 268(define-syntax network-error/code 269 (syntax-rules () 270 ((_ loc error-code msg . args) 271 (##sys#signal-hook #:network-error loc 272 (string-append (string-append msg " - ") 273 (error-code->message error-code)) 274 . args)))) 275 276(define parse-host 277 (let ((substring substring)) 278 (lambda (host proto) 279 (let ((len (##sys#size host))) 280 (let loop ((i 0)) 281 (if (fx>= i len) 282 (values host #f) 283 (let ((c (##core#inline "C_subchar" host i))) 284 (if (char=? c #\:) 285 (values 286 (substring host (fx+ i 1) len) 287 (let* ((s (substring host 0 i)) 288 (p (getservbyname s proto))) 289 (when (eq? 0 p) 290 (network-error 'tcp-connect "cannot compute port from service" s) ) 291 p) ) 292 (loop (fx+ i 1)) ) ) ) ) ) ) ) ) 293 294(define fresh-addr 295 (foreign-lambda* void ((scheme-pointer saddr) (unsigned-short port)) 296 "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;" 297 "memset(addr, 0, sizeof(struct sockaddr_in));" 298 "addr->sin_family = AF_INET;" 299 "addr->sin_port = htons(port);" 300 "addr->sin_addr.s_addr = htonl(INADDR_ANY);") ) 301 302(define (bind-socket style host port) 303 (let ((addr (make-string _sockaddr_in_size))) 304 (if host 305 (unless (gethostaddr addr host port) 306 (##sys#signal-hook 307 #:network-error 'tcp-listen 308 "getting listener host IP failed" host port) ) 309 (fresh-addr addr port) ) 310 (let ((s (socket _af_inet style 0))) 311 (when (eq? _invalid_socket s) 312 (##sys#error "cannot create socket") ) 313 ;; PLT makes this an optional arg to tcp-listen. Should we as well? 314 (when (eq? _socket_error (set-socket-options s)) 315 (network-error 'tcp-listen "error while setting up socket" s) ) 316 (when (eq? _socket_error (bind s addr _sockaddr_in_size)) 317 (network-error/close 'tcp-listen "cannot bind to socket" s host port) ) 318 s)) ) 319 320(define-constant default-backlog 100) 321 322(define (tcp-listen port #!optional (backlog default-backlog) host) 323 (##sys#check-fixnum port) 324 (when (or (fx< port 0) (fx> port 65535)) 325 (##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) ) 326 (##sys#check-fixnum backlog) 327 (let ((s (bind-socket _sock_stream host port))) 328 (when (eq? _socket_error (listen s backlog)) 329 (network-error/close 'tcp-listen "cannot listen on socket" s port) ) 330 (##sys#make-structure 'tcp-listener s) ) ) 331 332(define (tcp-listener? x) 333 (and (##core#inline "C_blockp" x) 334 (##sys#structure? x 'tcp-listener) ) ) 335 336(define (tcp-close tcpl) 337 (##sys#check-structure tcpl 'tcp-listener) 338 (let ((s (##sys#slot tcpl 1))) 339 (when (eq? _socket_error (close s)) 340 (network-error 'tcp-close "cannot close TCP socket" tcpl) ) ) ) 341 342(define-constant +input-buffer-size+ 1024) 343(define-constant +output-chunk-size+ 8192) 344 345(define tcp-buffer-size (make-parameter #f)) 346(define tcp-read-timeout) 347(define tcp-write-timeout) 348(define tcp-connect-timeout) 349(define tcp-accept-timeout) 350 351(let () 352 (define ((check loc) x) 353 (when x (##sys#check-fixnum x loc)) 354 x) 355 (define minute (fx* 60 1000)) 356 (set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout))) 357 (set! tcp-write-timeout (make-parameter minute (check 'tcp-write-timeout))) 358 (set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout))) 359 (set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) ) 360 361(define io-ports 362 (let ((tbs tcp-buffer-size)) 363 (lambda (loc fd) 364 (unless (##core#inline "make_socket_nonblocking" fd) 365 (network-error/close loc "cannot create TCP ports" fd) ) 366 (let* ((buf (make-string +input-buffer-size+)) 367 (data (vector fd #f #f buf 0)) 368 (buflen 0) 369 (bufindex 0) 370 (iclosed #f) 371 (oclosed #f) 372 (outbufsize (tbs)) 373 (outbuf (and outbufsize (fx> outbufsize 0) "")) 374 (read-input 375 (lambda () 376 (let* ((tmr (tcp-read-timeout)) 377 (dlr (and tmr (+ (current-process-milliseconds) tmr)))) 378 (let loop () 379 (let ((n (recv fd buf +input-buffer-size+ 0))) 380 (cond ((eq? _socket_error n) 381 (cond ((retry?) 382 (when dlr 383 (##sys#thread-block-for-timeout! 384 ##sys#current-thread dlr) ) 385 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input) 386 (##sys#thread-yield!) 387 (when (##sys#slot ##sys#current-thread 13) 388 (##sys#signal-hook 389 #:network-timeout-error 390 "read operation timed out" tmr fd) ) 391 (loop) ) 392 ((interrupted?) 393 (##sys#dispatch-interrupt loop)) 394 (else 395 (network-error #f "cannot read from socket" fd) ) ) ) 396 (else 397 (set! buflen n) 398 (##sys#setislot data 4 n) 399 (set! bufindex 0) ) ) ) )) ) ) 400 (in 401 (make-input-port 402 (lambda () 403 (when (fx>= bufindex buflen) 404 (read-input)) 405 (if (fx>= bufindex buflen) 406 #!eof 407 (let ((c (##core#inline "C_subchar" buf bufindex))) 408 (set! bufindex (fx+ bufindex 1)) 409 c) ) ) 410 (lambda () 411 (or (fx< bufindex buflen) 412 ;; XXX: This "knows" that check_fd_ready is 413 ;; implemented using a winsock2 call on Windows 414 (let ((f (check-fd-ready fd))) 415 (when (eq? _socket_error f) 416 (network-error #f "cannot check socket for input" fd) ) 417 (eq? f 1) ) ) ) 418 (lambda () 419 (unless iclosed 420 (set! iclosed #t) 421 (unless (##sys#slot data 1) (shutdown fd _shut_rd)) 422 (when (and oclosed (eq? _socket_error (close fd))) 423 (network-error #f "cannot close socket input port" fd) ) ) ) 424 (lambda () 425 (when (fx>= bufindex buflen) 426 (read-input)) 427 (if (fx< bufindex buflen) 428 (##core#inline "C_subchar" buf bufindex) 429 #!eof)) 430 (lambda (p n dest start) ; read-string! 431 (let loop ((n n) (m 0) (start start)) 432 (cond ((eq? n 0) m) 433 ((fx< bufindex buflen) 434 (let* ((rest (fx- buflen bufindex)) 435 (n2 (if (fx< n rest) n rest))) 436 (##core#inline "C_substring_copy" buf dest bufindex (fx+ bufindex n2) start) 437 (set! bufindex (fx+ bufindex n2)) 438 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ) 439 (else 440 (read-input) 441 (if (eq? buflen 0) 442 m 443 (loop n m start) ) ) ) ) ) 444 (lambda (p limit) ; read-line 445 (when (fx>= bufindex buflen) 446 (read-input)) 447 (if (fx>= bufindex buflen) 448 #!eof 449 (let ((limit (or limit (fx- most-positive-fixnum bufindex)))) 450 (receive (next line full-line?) 451 (##sys#scan-buffer-line 452 buf 453 (fxmin buflen (fx+ bufindex limit)) 454 bufindex 455 (lambda (pos) 456 (let ((nbytes (fx- pos bufindex))) 457 (cond ((fx>= nbytes limit) 458 (values #f pos #f)) 459 (else (read-input) 460 (set! limit (fx- limit nbytes)) 461 (if (fx< bufindex buflen) 462 (values buf bufindex 463 (fxmin buflen 464 (fx+ bufindex limit))) 465 (values #f bufindex #f))))) ) ) 466 ;; Update row & column position 467 (if full-line? 468 (begin 469 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1)) 470 (##sys#setislot p 5 0)) 471 (##sys#setislot p 5 (fx+ (##sys#slot p 5) 472 (##sys#size line)))) 473 (set! bufindex next) 474 line) )) ) 475 (lambda (p) ; read-buffered 476 (if (fx>= bufindex buflen) 477 "" 478 (let ((str (##sys#substring buf bufindex buflen))) 479 (set! bufindex buflen) 480 str))) 481 ) ) 482 (output 483 (lambda (s) 484 (let ((tmw (tcp-write-timeout))) 485 (let loop ((len (##sys#size s)) 486 (offset 0) 487 (dlw (and tmw (+ (current-process-milliseconds) tmw)))) 488 (let* ((count (fxmin +output-chunk-size+ len)) 489 (n (send fd s offset count 0))) 490 (cond ((eq? _socket_error n) 491 (cond ((retry?) 492 (when dlw 493 (##sys#thread-block-for-timeout! 494 ##sys#current-thread dlw) ) 495 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output) 496 (##sys#thread-yield!) 497 (when (##sys#slot ##sys#current-thread 13) 498 (##sys#signal-hook 499 #:network-timeout-error 500 "write operation timed out" tmw fd) ) 501 (loop len offset dlw) ) 502 ((interrupted?) 503 (##sys#dispatch-interrupt 504 (cut loop len offset dlw))) 505 (else 506 (network-error #f "cannot write to socket" fd) ) ) ) 507 ((fx< n len) 508 (loop (fx- len n) (fx+ offset n) 509 (if (fx= n 0) 510 tmw 511 ;; If we wrote *something*, reset timeout 512 (and tmw (+ (current-process-milliseconds) tmw)) )) ) ) ) )) ) ) 513 (out 514 (make-output-port 515 (if outbuf 516 (lambda (s) 517 (set! outbuf (##sys#string-append outbuf s)) 518 (when (fx>= (##sys#size outbuf) outbufsize) 519 (output outbuf) 520 (set! outbuf "") ) ) 521 (lambda (s) 522 (when (fx> (##sys#size s) 0) 523 (output s)) ) ) 524 (lambda () 525 (unless oclosed 526 (set! oclosed #t) 527 (when (and outbuf (fx> (##sys#size outbuf) 0)) 528 (output outbuf) 529 (set! outbuf "") ) 530 (unless (##sys#slot data 2) (shutdown fd _shut_wr)) 531 (when (and iclosed (eq? _socket_error (close fd))) 532 (network-error #f "cannot close socket output port" fd) ) ) ) 533 (and outbuf 534 (lambda () 535 (when (fx> (##sys#size outbuf) 0) 536 (output outbuf) 537 (set! outbuf "") ) ) ) ) ) ) 538 (##sys#setslot in 3 "(tcp)") 539 (##sys#setslot out 3 "(tcp)") 540 (##sys#setslot in 7 'socket) 541 (##sys#setslot out 7 'socket) 542 (##sys#set-port-data! in data) 543 (##sys#set-port-data! out data) 544 (values in out) ) ) ) ) 545 546(define (tcp-accept tcpl) 547 (##sys#check-structure tcpl 'tcp-listener) 548 (let* ((fd (##sys#slot tcpl 1)) 549 (tma (tcp-accept-timeout)) 550 (dla (and tma (+ tma (current-process-milliseconds))))) 551 (let loop () 552 (when dla 553 (##sys#thread-block-for-timeout! ##sys#current-thread dla) ) 554 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input) 555 (##sys#thread-yield!) 556 (if (##sys#slot ##sys#current-thread 13) 557 (##sys#signal-hook 558 #:network-timeout-error 559 'tcp-accept 560 "accept operation timed out" tma fd) ) 561 (let ((fd (accept fd #f #f))) 562 (cond ((not (eq? _invalid_socket fd)) 563 (io-ports 'tcp-accept fd)) 564 ((interrupted?) 565 (##sys#dispatch-interrupt loop)) 566 (else 567 (network-error 'tcp-accept "could not accept from listener" tcpl)))) ) ) ) 568 569(define (tcp-accept-ready? tcpl) 570 (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?) 571 ;; XXX: This "knows" that check_fd_ready is implemented using a winsock2 call 572 (let ((f (check-fd-ready (##sys#slot tcpl 1)))) 573 (when (eq? _socket_error f) 574 (network-error 'tcp-accept-ready? "cannot check socket for input" tcpl) ) 575 (eq? 1 f) ) ) 576 577(define get-socket-error 578 (foreign-lambda* int ((int socket)) 579 "int err, optlen;" 580 "optlen = sizeof(err);" 581 "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == SOCKET_ERROR)" 582 " C_return(SOCKET_ERROR);" 583 "C_return(err);")) 584 585(define (tcp-connect host . more) 586 (let* ((port (optional more #f)) 587 (tmc (tcp-connect-timeout)) 588 (dlc (and tmc (+ (current-process-milliseconds) tmc))) 589 (addr (make-string _sockaddr_in_size))) 590 (##sys#check-string host) 591 (unless port 592 (set!-values (host port) (parse-host host "tcp")) 593 (unless port (##sys#signal-hook #:domain-error 'tcp-connect "no port specified" host)) ) 594 (##sys#check-fixnum port) 595 (unless (gethostaddr addr host port) 596 (##sys#signal-hook #:network-error 'tcp-connect "cannot find host address" host) ) 597 (let ((s (socket _af_inet _sock_stream 0))) 598 (when (eq? _invalid_socket s) 599 (network-error 'tcp-connect "cannot create socket" host port) ) 600 (when (eq? _socket_error (set-socket-options s)) 601 (network-error/close 'tcp-connect "error while setting up socket" s) ) 602 (unless (##core#inline "make_socket_nonblocking" s) 603 (network-error/close 'tcp-connect "fcntl() failed" s) ) 604 (let loop () 605 (when (eq? _socket_error (connect s addr _sockaddr_in_size)) 606 (cond ((in-progress?) ; Wait till it's available via select/poll 607 (when dlc 608 (##sys#thread-block-for-timeout! ##sys#current-thread dlc)) 609 (##sys#thread-block-for-i/o! ##sys#current-thread s #:output) 610 (##sys#thread-yield!)) ; Don't loop: it's connected now 611 ((interrupted?) 612 (##sys#dispatch-interrupt loop)) 613 (else 614 (network-error/close 615 'tcp-connect "cannot connect to socket" s host port))))) 616 (let ((err (get-socket-error s))) 617 (cond ((eq? _socket_error err) 618 (network-error/close 'tcp-connect "getsockopt() failed" s)) 619 ((fx> err 0) 620 (close s) 621 (network-error/code 'tcp-connect err "cannot create socket")))) 622 (io-ports 'tcp-connect s))) ) 623 624(define (tcp-port->fileno p loc) 625 (let ((data (##sys#port-data p))) 626 (if (vector? data) ; a meagre test, but better than nothing 627 (##sys#slot data 0) 628 (error loc "argument does not appear to be a TCP port" p)))) 629 630(define (tcp-addresses p) 631 (##sys#check-open-port p 'tcp-addresses) 632 (let ((fd (tcp-port->fileno p 'tcp-addresses))) 633 (values 634 (or (getsockname fd) 635 (network-error 'tcp-addresses "cannot compute local address" p) ) 636 (or (getpeername fd) 637 (network-error 'tcp-addresses "cannot compute remote address" p) ) ) ) ) 638 639(define (tcp-port-numbers p) 640 (##sys#check-open-port p 'tcp-port-numbers) 641 (let ((fd (tcp-port->fileno p 'tcp-port-numbers))) 642 (let ((sp (getsockport fd)) 643 (pp (getpeerport fd))) 644 (when (eq? -1 sp) 645 (network-error 'tcp-port-numbers "cannot compute local port" p) ) 646 (when (eq? -1 pp) 647 (network-error 'tcp-port-numbers "cannot compute remote port" p) ) 648 (values sp pp)))) 649 650(define (tcp-listener-port tcpl) 651 (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port) 652 (let* ((fd (##sys#slot tcpl 1)) 653 (port (getsockport fd))) 654 (when (eq? -1 port) 655 (network-error 'tcp-listener-port "cannot obtain listener port" tcpl fd) ) 656 port) ) 657 658(define (tcp-abandon-port p) 659 (##sys#check-open-port p 'tcp-abandon-port) 660 (##sys#setislot (##sys#port-data p) (##sys#slot p 1) #t)) 661 662(define (tcp-listener-fileno l) 663 (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno) 664 (##sys#slot l 1) ) 665 666) 667