/socket.scm
Scheme | 1340 lines | 1038 code | 105 blank | 197 comment | 13 complexity | 80541bfb732657d98db8edfb590ef9d4 MD5 | raw file
Large files files are truncated, but you can click here to view the full file
1;;; socket extension 2 3;;; License 4 5;; Some code was derived from Chicken core tcp.scm. 6 7;; Copyright (c) 2011-2012, Jim Ursetto 8;; Copyright (c) 2008-2011, The Chicken Team 9;; Copyright (c) 2000-2007, Felix L. Winkelmann 10;; All rights reserved. 11 12;; Redistribution and use in source and binary forms, with or without 13;; modification, are permitted provided that the following conditions 14;; are met: 15 16;; - Redistributions of source code must retain the above copyright 17;; notice, this list of conditions and the following disclaimer. 18;; - Redistributions in binary form must reproduce the above copyright 19;; notice, this list of conditions and the following disclaimer in 20;; the documentation and/or other materials provided with the 21;; distribution. 22;; - Neither the name of the author nor the names of its contributors 23;; may be used to endorse or promote products derived from this 24;; software without specific prior written permission. 25 26;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 27;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 28;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 29;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 30;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, 31;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 32;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 33;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 34;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 35;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 36;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED 37;; OF THE POSSIBILITY OF SUCH DAMAGE. 38 39 40(import scheme (except chicken errno) foreign) 41(use foreigners) 42(use srfi-4 extras ports) 43(use (only srfi-13 string-index)) 44;; Pull TCP in w/o importing so ##sys#tcp-port->fileno is defined 45;; and network is started up. 46(require-library tcp) 47 48#> #include "socket.h" <# 49 50;;; error handling 51 52(define-foreign-variable errno int "errno") 53(define strerror (foreign-lambda c-string "skt_strerror" int)) 54 55(define-inline (type-error where msg . args) 56 (apply ##sys#signal-hook #:type-error where msg args)) 57(define-inline (domain-error where msg . args) 58 (apply ##sys#signal-hook #:domain-error where msg args)) 59(define-inline (network-error where msg . args) 60 (apply ##sys#signal-hook #:network-error where msg args)) 61(define-inline (network-error/errno where msg . args) 62 (let ((err errno)) 63 (##sys#update-errno) ;; Note that this may cause context switch, and wipe out errno 64 (apply ##sys#signal-hook #:network-error where 65 (string-append msg " - " (strerror err)) 66 args))) 67(define-inline (network-error/errno* where err msg . args) 68;;(##sys#update-errno) 69 (apply ##sys#signal-hook #:network-error where 70 (string-append msg " - " (strerror err)) 71 args)) 72(define-inline (transient-network-error/errno* where err msg . args) 73 (abort 74 (make-composite-condition 75 (make-property-condition 'exn 'location where 76 'message (string-append msg " - " (strerror err)) 77 'arguments args) 78 (make-property-condition 'i/o) 79 (make-property-condition 'net 'errno err) 80 (make-property-condition 'transient)))) 81(define-inline (unsupported-error where msg . args) 82 (abort 83 (make-composite-condition 84 (make-property-condition 'exn 'location where 85 'message msg 86 'arguments args) 87 (make-property-condition 'i/o) 88 (make-property-condition 'net) 89 (make-property-condition 'unsupported)))) 90 91;;; constants 92 93;; (define-foreign-flag AI_NUMERICSERV) => 94;; (begin (foreign-declare "#ifndef AI_NUMERICSERV\n#define AI_NUMERICSERV 0\n#endif\n") 95;; (define-foreign-variable AI_NUMERICSERV int "AI_NUMERICSERV") 96;; (define-for-syntax (c-name sym) 97;; (string-translate (string-upcase (symbol->string sym)) "/" "_")) 98(define-syntax define-foreign-flag 99 (lambda (e r c) 100 (let ((name (cadr e))) 101 `(,(r 'begin) 102 (,(r 'foreign-declare) 103 ,(sprintf "#ifndef ~A\n#define ~A 0\n#endif\n" name name)) 104 (,(r 'define-foreign-variable) ,name ,(r 'int) ,(symbol->string name)))))) 105 106(define-foreign-enum-type (address-family int) 107 (address-family->integer integer->address-family) 108 ((af/unspec AF_UNSPEC) AF_UNSPEC) 109 ((af/inet AF_INET) AF_INET) 110 ((af/inet6 AF_INET6) AF_INET6) 111;; #+AF_UNIX ((af/unix AF_UNIX) AF_UNIX) 112 ) 113#+AF_UNIX (define-foreign-variable AF_UNIX int AF_UNIX) 114(define af/unspec AF_UNSPEC) 115(define af/inet AF_INET) 116(define af/inet6 AF_INET6) 117(define af/unix #? (AF_UNIX AF_UNIX #f)) 118 119(define-foreign-enum-type (socket-type int) 120 (socket-type->integer integer->socket-type) 121 ((sock/stream SOCK_STREAM) SOCK_STREAM) 122 ((sock/dgram SOCK_DGRAM) SOCK_DGRAM) 123 ((sock/raw SOCK_RAW) SOCK_RAW)) 124(define sock/stream SOCK_STREAM) 125(define sock/dgram SOCK_DGRAM) 126(define sock/raw SOCK_RAW) 127 128;; These are for address-information, not socket options -- so TCP and UDP only. 129(define-foreign-enum-type (protocol-type int) 130 (protocol-type->integer integer->protocol-type) 131 ((ipproto/tcp IPPROTO_TCP) IPPROTO_TCP) 132 ((ipproto/udp IPPROTO_UDP) IPPROTO_UDP)) 133(define ipproto/tcp IPPROTO_TCP) 134(define ipproto/udp IPPROTO_UDP) 135 136(define-foreign-variable AI_CANONNAME int "AI_CANONNAME") 137(define ai/canonname AI_CANONNAME) 138(define-foreign-variable AI_NUMERICHOST int "AI_NUMERICHOST") 139(define ai/numerichost AI_NUMERICHOST) 140(define-foreign-variable AI_PASSIVE int "AI_PASSIVE") 141(define ai/passive AI_PASSIVE) 142;; These flags will be set to 0 if undefined. The ones above 143;; will throw a compilation error since they are required. 144(define-foreign-flag AI_NUMERICSERV) 145(define ai/numericserv AI_NUMERICSERV) 146(define-foreign-flag AI_ALL) 147(define ai/all AI_ALL) 148(define-foreign-flag AI_V4MAPPED) 149(define ai/v4mapped AI_V4MAPPED) 150(define-foreign-flag AI_ADDRCONFIG) 151(define ai/addrconfig AI_ADDRCONFIG) 152(define-foreign-flag AI_MASK) 153(define ai/mask AI_MASK) 154(define-foreign-flag AI_DEFAULT) 155(define ai/default AI_DEFAULT) 156 157(define-foreign-variable NI_MAXHOST int "NI_MAXHOST") 158(define-foreign-variable NI_MAXSERV int "NI_MAXSERV") 159(define-foreign-variable NI_NUMERICHOST int "NI_NUMERICHOST") 160(define-foreign-variable NI_NUMERICSERV int "NI_NUMERICSERV") 161(define-foreign-variable NI_DGRAM int "NI_DGRAM") 162(define-foreign-variable NI_NAMEREQD int "NI_NAMEREQD") 163(define-foreign-variable NI_NOFQDN int "NI_NOFQDN") 164(define ni/numerichost NI_NUMERICHOST) 165(define ni/numericserv NI_NUMERICSERV) 166(define ni/dgram NI_DGRAM) 167(define ni/namereqd NI_NAMEREQD) 168(define ni/nofqdn NI_NOFQDN) 169 170;;; 171 172(define-foreign-record-type (sa "struct sockaddr") 173 (int sa_family sa-family)) 174(define-foreign-variable _sockaddr_storage_size int "sizeof(struct sockaddr_storage)") 175 176(define-record sockaddr family blob) 177 178(define (sa->sockaddr sa len) ;; sa -- c-pointer; len -- length of sockaddr struct 179 (if (= len 0) ;; for example, socket-receive-from! returns 0 len on connection-oriented socket 180 #f 181 (make-sockaddr (sa-family sa) ;; Assume when len > 0, it at least includes the family. 182 (let ((b (make-blob len))) 183 ((foreign-lambda void C_memcpy scheme-pointer c-pointer int) 184 b sa len) 185 b)))) 186 187(define (sockaddr-len A) 188 (blob-size (sockaddr-blob A))) 189(define (sockaddr-address A) 190 (let ((af (sockaddr-family A))) 191 (cond ((or (= af AF_INET) 192 (= af AF_INET6)) 193 (car (getnameinfo A (+ NI_NUMERICHOST NI_NUMERICSERV)))) 194 #? (AF_UNIX 195 ((= af AF_UNIX) (sockaddr-path A)) 196 (#f #f)) 197 (else #f)))) 198 199;; Port and path will return #f if called on the wrong sockaddr type. 200;; Maybe throw an error instead? 201(define (sockaddr-port A) 202 (or 203 ((foreign-lambda* scheme-object ((scheme-pointer sa)) 204 "switch (((struct sockaddr*)sa)->sa_family) {" 205 "case AF_INET: C_return(C_fix(ntohs(((struct sockaddr_in*)sa)->sin_port)));" 206 "case AF_INET6: C_return(C_fix(ntohs(((struct sockaddr_in6*)sa)->sin6_port)));" 207 "default: C_return(C_SCHEME_FALSE); }") 208 (sockaddr-blob A)) 209 (network-error 'sockaddr-port "unable to obtain port for socket address" A))) 210(define (sockaddr-path A) 211 #? (AF_UNIX 212 (or 213 ((foreign-lambda* c-string ((scheme-pointer sa)) 214 "switch (((struct sockaddr*)sa)->sa_family) {" 215 "case AF_UNIX: C_return(((struct sockaddr_un*)sa)->sun_path);" 216 "default: C_return(NULL); }" 217 ) 218 (sockaddr-blob A)) 219 (network-error 'sockaddr-path "unable to obtain path for socket address" A)) 220 (error 'sockaddr-path "UNIX sockets are not supported"))) 221 222(define-record-printer (sockaddr A out) 223 (fprintf out "#<sockaddr ~S>" 224 (sockaddr->string A) 225 ;; (integer->address-family (sockaddr-family A)) 226 )) 227 228;; Convert socket address/path to a compact string, mainly for display purposes. 229(define (sockaddr->string A) 230 (let ((af (sockaddr-family A))) 231 (cond ((or (= af AF_INET) 232 (= af AF_INET6)) 233 (let* ((ni (getnameinfo A (+ NI_NUMERICHOST NI_NUMERICSERV))) 234 (h (car ni)) 235 (p (cdr ni))) 236 (if (string=? p "0") 237 h 238 (if (= af AF_INET6) 239 (string-append "[" h "]" ":" p) 240 (string-append h ":" p))))) 241 #?(AF_UNIX 242 ((= af AF_UNIX) 243 (sockaddr-path A)) ;; or reach directly into blob here 244 (#f #f)) 245 (else 246 #f)))) 247 248;; Intent of this is a direct call to getnameinfo ala inet_ntop, returning 249;; a plain string; however, error handling is hard. 250;; (define (sockaddr->ip-string A) 251;; (foreign-lambda* c-string ((scheme-pointer sa)) 252;; "" 253;; )) 254 255(define-foreign-record-type (ai "struct addrinfo") 256 (constructor: alloc-ai) 257 (destructor: free-ai) ; similar name! 258 (int ai_flags ai-flags set-ai-flags!) 259 (int ai_family ai-family set-ai-family!) 260 (int ai_socktype ai-socktype set-ai-socktype!) 261 (int ai_protocol ai-protocol set-ai-protocol!) 262 (int ai_addrlen ai-addrlen) 263 ((c-pointer sa) ai_addr ai-addr) ;; non-null? 264 (c-string ai_canonname ai-canonname) 265 ((c-pointer ai) ai_next ai-next)) 266 267(define-syntax non-nil 268 (syntax-rules () 269 ((_ a) 270 (let ((x a)) 271 (if (or (not x) (null? x)) #f x))) 272 ((_ a . rest) 273 (let ((x a)) 274 (if (or (not x) (null? x)) 275 (non-nil . rest) 276 x))))) 277 278(define-record addrinfo 279 flags family socktype protocol address canonname) 280(define-record-printer (addrinfo a out) 281 (fprintf out "#<addrinfo ~S ~S ~S ~S~A>" 282 (sockaddr->string (addrinfo-address a)) 283 (non-nil (integer->address-family (addrinfo-family a)) (addrinfo-family a)) 284 (non-nil (integer->socket-type (addrinfo-socktype a)) (addrinfo-socktype a)) 285 (non-nil (integer->protocol-type (addrinfo-protocol a)) (addrinfo-protocol a)) 286 (cond ((addrinfo-canonname a) 287 => (lambda (cn) (sprintf " canonical: ~S" cn))) 288 (else "")) 289 ;; (addrinfo-flags a) ;; flag display isn't that interesting 290 )) 291 292(define (ai->addrinfo ai) ;; construct addrinfo obj from ai ptr, with embedded sockaddr obj 293 (make-addrinfo 294 (ai-flags ai) 295 (ai-family ai) 296 (ai-socktype ai) 297 (ai-protocol ai) 298 (ai->sockaddr ai) 299 (ai-canonname ai))) 300(define (ai->sockaddr ai) ;; direct construction of sockaddr object from ai pointer 301 (and-let* ((addr (ai-addr ai))) 302 (sa->sockaddr addr (ai-addrlen ai)))) 303 304(define (ai-list->addrinfo ai) ;; construct addrinfo object list from ai linked list 305 (let loop ((ai ai) 306 (L '())) 307 (if ai 308 (loop (ai-next ai) 309 (cons (ai->addrinfo ai) L)) 310 (reverse L)))) 311 312(define (alloc-null-ai) 313 (let ((null! (foreign-lambda* void ((ai ai)) 314 "memset(ai,0,sizeof(*ai));" 315 )) 316 (ai (alloc-ai))) 317 (null! ai) 318 ai)) 319(define _getaddrinfo 320 (foreign-lambda int getaddrinfo c-string c-string ai (c-pointer ai))) 321(define freeaddrinfo 322 (foreign-lambda void freeaddrinfo ai)) 323(define _getnameinfo 324 (foreign-lambda int skt_getnameinfo scheme-pointer int scheme-pointer 325 int scheme-pointer int int)) 326 327(define gai_strerror (foreign-lambda c-string "gai_strerror" int)) 328 329(define-foreign-variable eai/noname int "EAI_NONAME") 330 331;; FIXME: hints constructor is craaaap 332;; Returns a c-pointer; must call freeaddrinfo on result once used. 333(define (getaddrinfo/ai node service family socktype protocol flags) 334 (let-location ((res c-pointer)) 335 (let ((hints #f)) 336 (define hints (alloc-null-ai)) 337 (when family (set-ai-family! hints family)) 338 (when socktype (set-ai-socktype! hints socktype)) 339 (when flags (set-ai-flags! hints flags)) 340 (when protocol (set-ai-protocol! hints protocol)) 341 (let ((rc (_getaddrinfo node service hints #$res))) 342 (when hints (free-ai hints)) 343 (cond ((= 0 rc) 344 res) 345 ((= eai/noname rc) ;; save exceptions for real errors 346 #f) 347 (else 348 (when res (freeaddrinfo res)) ;; correct?? 349 (network-error 'getaddrinfo (gai_strerror rc) node))))))) 350(define (getaddrinfo node service family socktype protocol flags) 351 (let* ((ai (getaddrinfo/ai node service family socktype protocol flags)) 352 (addrinfo (ai-list->addrinfo ai))) 353 (when ai (freeaddrinfo ai)) 354 addrinfo)) 355 356(define (address-information node service #!key family (type sock/stream) protocol flags) 357 (let ((service (if (integer? service) (number->string service) service))) 358 (getaddrinfo node service family type protocol flags))) 359 360;; Constructor for socket address object from IP address string & SERVICE number. 361;; The usual way to create such an address is via address-information; this is 362;; a more efficient shortcut. 363;; When ip is #f, the socket is considered intended for passive use (bind) and 364;; the unspecified address will be returned. (Implicitly affects name-information.) 365;; However, the unspecified address may not be useful, as it will return either 366;; an inet or inet6 address (which may not match the socket family). To avoid 367;; this, specify "::" or "0.0.0.0" explicitly. 368;; TODO: Port range should probably be checked. 369(define (inet-address ip port) 370 (let ((port (and port 371 (cond ((and (exact? port) (number->string port))) 372 (else (domain-error 'inet-address 373 "port must be a numeric value or #f" port))))) 374 (passive (if ip 0 AI_PASSIVE))) 375 (let ((ai (getaddrinfo/ai ip port #f #f #f 376 (+ AI_NUMERICHOST passive AI_NUMERICSERV)))) 377 (unless ai 378 (network-error 'inet-address "invalid internet address" ip port)) 379 (let ((saddr (ai->sockaddr ai))) 380 (freeaddrinfo ai) 381 saddr)))) 382 383;; ADDR is either a SOCKADDR object, or an IPv4 or IPv6 string. 384;; Converts returned port to numeric if possible. Does not convert 0 to #f though. 385;; Note: Should add AI_NUMERICSERV to getaddrinfo call, but it may not be portable. 386;; Note: (car (name-information addr flags: ni/numerichost)) == 387;; (sockaddr-address (inet-address addr 0)), so there is some redundancy. 388;; (name-information (inet-address "::1" 0)) 389(define (name-information saddr #!optional (flags 0)) 390 (define (massage ni) 391 (cond ((string->number (cdr ni)) 392 => (lambda (p) (cons (car ni) p))) 393 (else ni))) 394 (massage (getnameinfo (if (string? saddr) (inet-address saddr #f) saddr) 395 flags))) 396 397(define (getnameinfo saddr flags) 398 (let* ((sa (sockaddr-blob saddr)) 399 (salen (sockaddr-len saddr))) 400 (let ((node (make-string NI_MAXHOST)) 401 (serv (make-string NI_MAXSERV))) 402 (let ((rc (_getnameinfo sa salen 403 node NI_MAXHOST 404 serv NI_MAXSERV flags))) 405 (cond ((= rc 0) 406 (cons (substring node 0 (string-index node #\nul)) 407 (substring serv 0 (string-index serv #\nul)))) 408 (else 409 (network-error 'getnameinfo (gai_strerror rc)))))))) 410 411 412 413;;; socket operations 414 415(define socket-connect-timeout) 416(define socket-receive-timeout) 417(define socket-send-timeout) 418(define socket-accept-timeout) 419 420(let () 421 (define ((check loc) x) 422 (when x (##sys#check-exact x loc)) 423 x) 424 (define minute (fx* 60 1000)) 425 (set! socket-receive-timeout (make-parameter minute (check 'socket-receive-timeout))) 426 (set! socket-send-timeout (make-parameter minute (check 'socket-send-timeout))) 427 (set! socket-connect-timeout (make-parameter #f (check 'socket-connect-timeout))) 428 (set! socket-accept-timeout (make-parameter #f (check 'socket-accept-timeout)))) 429 430(define-foreign-variable _invalid_socket int "INVALID_SOCKET") 431(define-foreign-variable _ewouldblock int "EWOULDBLOCK") 432(define-foreign-variable _einprogress int "EINPROGRESS") 433(define-foreign-variable _econnrefused int "ECONNREFUSED") 434(define-foreign-variable _etimedout int "ETIMEDOUT") 435(define-foreign-variable _enetunreach int "ENETUNREACH") 436(define-foreign-variable _ehostunreach int "EHOSTUNREACH") 437(define-foreign-variable _enotconn int "ENOTCONN") 438(define-foreign-variable _einval int "EINVAL") 439(define-foreign-variable _enoprotoopt int "ENOPROTOOPT") 440 441(define-foreign-variable SHUT_RD int "SHUT_RD") 442(define-foreign-variable SHUT_WR int "SHUT_WR") 443(define-foreign-variable SHUT_RDWR int "SHUT_RDWR") 444(define shut/rd SHUT_RD) 445(define shut/wr SHUT_WR) 446(define shut/rdwr SHUT_RDWR) 447 448(define _close_socket (foreign-lambda int "closesocket" int)) 449 450(define _make_socket_nonblocking 451 (foreign-lambda* bool ((int fd)) 452 "#ifdef _WIN32\n" 453 "unsigned long val = 1; C_return(ioctlsocket(fd, FIONBIO, &val) == 0);\n" 454 "#else\n" 455 "int val = fcntl(fd, F_GETFL, 0);" 456 "if(val == -1) C_return(0);" 457 "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);\n" 458 "#endif\n")) 459 460(define select-for-read 461 (foreign-lambda* int ((int fd)) 462 "fd_set in; 463 struct timeval tm; 464 int rv; 465 FD_ZERO(&in); 466 FD_SET(fd, &in); 467 tm.tv_sec = tm.tv_usec = 0; 468 rv = select(fd + 1, &in, NULL, NULL, &tm); 469 if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; } 470 C_return(rv);") ) 471 472(define select-for-write 473 (foreign-lambda* int ((int fd)) 474 "fd_set out; 475 struct timeval tm; 476 int rv; 477 FD_ZERO(&out); 478 FD_SET(fd, &out); 479 tm.tv_sec = tm.tv_usec = 0; 480 rv = select(fd + 1, NULL, &out, NULL, &tm); 481 if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; } 482 C_return(rv);") ) 483 484;; On Windows, non-blocking connection errors show up in except fds. 485(define select-for-write-or-except 486 (foreign-lambda* int ((int fd)) 487 "fd_set out, exc; 488 struct timeval tm; 489 int rv; 490 FD_ZERO(&out); FD_ZERO(&exc); 491 FD_SET(fd, &out); FD_SET(fd, &exc); 492 tm.tv_sec = tm.tv_usec = 0; 493 rv = select(fd + 1, NULL, &out, &exc, &tm); 494 if(rv > 0) { rv = (FD_ISSET(fd, &out) || FD_ISSET(fd, &exc)) ? 1 : 0; } 495 C_return(rv);") ) 496 497(define-inline (socket-timeout-error where timeout so) 498 (##sys#signal-hook 499 #:network-timeout-error 500 where "operation timed out" timeout so)) 501 502(define (block-for-timeout! where timeout fd type #!optional cleanup) ;; #f permitted for WHERE 503 ;; No exported way to simultaneously wait on either an FD or a timeout event. 504 (when timeout 505 (##sys#thread-block-for-timeout! 506 ##sys#current-thread 507 (+ (current-milliseconds) timeout))) 508 (##sys#thread-block-for-i/o! ##sys#current-thread fd type) 509 (##sys#thread-yield!) 510 (when (##sys#slot ##sys#current-thread 13) 511 (if cleanup (cleanup)) 512 (##sys#signal-hook 513 #:network-timeout-error 514 where "operation timed out" timeout fd))) 515 516(define (get-socket-error s) 517 ;; http://cr.yp.to/docs/connect.html describes alternative ways to retrieve 518 ;; non-blocking socket errors. 519 (define _getsockerr 520 (foreign-lambda* int ((int socket)) 521 "int err;" 522 "int optlen = sizeof(err);" 523 "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)" 524 "C_return(-1);" 525 "C_return(err);")) 526 (let ((err (_getsockerr s))) 527 (cond ((fx= err 0) #f) 528 ((fx> err 0) err) 529 (else 530 (_close_socket s) 531 (network-error/errno 'get-socket-error "unable to obtain socket error code"))))) 532 533;; Silly parsing of inet address string into host and port. 534;; Note: if unparsable into host/port, return full string as hostname, and let caller deal with it. 535;; If host or port is empty, returns #f for that field. 536(define (parse-inet-address str) 537 (let ((len (string-length str))) 538 (if (= len 0) 539 (values "" #f) 540 (if (char=? (string-ref str 0) #\[) 541 (let ((j (string-index str #\] 1))) 542 (if j 543 (let* ((host (substring str 1 j)) 544 (host (if (string=? host "") #f host))) 545 (if (= (fx+ j 1) len) 546 (values host #f) ;; bracketed address w/o port 547 (if (char=? (string-ref str (fx+ j 1)) #\:) 548 (let* ((port (substring str (fx+ j 2))) 549 (port (if (string=? port "") #f port))) 550 (values host port)) ;; bracketed address w/ port 551 (values str #f)))) 552 (values str #f))) 553 (let ((j (string-index str #\:))) 554 (if j 555 (let ((k (string-index str #\: (fx+ j 1)))) 556 (if k 557 (values str #f) ;; a bare IPv6 address 558 (let* ((host (substring str 0 j)) 559 (host (if (string=? host "") #f host)) 560 (port (substring str (fx+ j 1))) 561 (port (if (string=? port "") #f port))) 562 (values host port)))) ;; IPv4 address w/port 563 (values str #f)) ;; an IPv4 address sans port 564 ))))) 565 566(define-record socket fileno family type protocol) ;; NB socket? conflicts with Unit posix 567(define-inline (%socket-fileno so) 568 (##sys#slot so 1)) 569(define-inline (check-socket so loc) 570 (unless (socket? so) 571 (type-error loc "argument is not a socket" so))) 572 573(define-record-printer (socket s out) 574 (fprintf out "#<socket fd:~S ~S ~S>" 575 (socket-fileno s) 576 (non-nil (integer->address-family (socket-family s)) (socket-family s)) 577 (non-nil (integer->socket-type (socket-type s)) (socket-type s)) 578 #;(non-nil (integer->protocol-type (socket-protocol s)) (socket-protocol s)) 579 )) 580 581(define (socket family socktype #!optional (protocol 0)) 582 (define _socket (foreign-lambda int "socket" int int int)) 583 (let ((s (_socket family socktype protocol))) 584 (when (eq? _invalid_socket s) 585 (network-error/errno 'socket "cannot create socket" 586 (non-nil (integer->address-family family) family) 587 (non-nil (integer->socket-type socktype) socktype) 588 (non-nil (integer->protocol-type protocol) protocol))) 589 (let ((so (make-socket s family socktype protocol))) 590 ;; Immediately set all sockets in non-blocking mode, even UDP. 591 ;; See http://lists.nongnu.org/archive/html/chicken-users/2013-06/msg00062.html 592 (unless (_make_socket_nonblocking s) 593 (network-error/errno 'socket "unable to set socket to non-blocking" so)) 594 so))) 595 596(use srfi-18) 597 598;; Stolen from sql-de-lite (itself stolen from sqlite), but modified to respect 599;; actual elapsed time instead of estimated elapsed time (to mostly avoid scheduling jitter). 600;; The polling intervals are not altered, only the total elapsed time. 601(define busy-timeout 602 (let* ((delays '#(1 2 5 10 15 20 25 25 25 50 50 100)) 603 (ndelay (vector-length delays))) 604 (lambda (ms) 605 (cond 606 ((< ms 0) (domain-error 'busy-timeout "timeout must be non-negative" ms)) 607 ((= ms 0) #f) 608 (else 609 (let ((start (current-milliseconds))) 610 (lambda (so count) 611 (let* ((delay (vector-ref delays (min count (- ndelay 1)))) 612 (prior (- (current-milliseconds) start))) 613 (let ((delay (if (> (+ prior delay) ms) 614 (- ms prior) 615 delay))) 616 (cond ((<= delay 0) #f) 617 (else 618 (thread-sleep! (/ delay 1000)) ;; silly division 619 #t))))))))))) 620 621(define-constant +largest-fixnum+ (##sys#fudge 21)) 622 623;; Returns a special "transient" error (exn i/o net transient) if connection failure 624;; was due to refusal, network down, etc.; in which case, the same or another 625;; address could be tried later. (The socket is still closed, though.) 626(define (socket-connect so saddr) 627 (define _connect (foreign-lambda int "connect" int scheme-pointer int)) 628 (define (refused? err) 629 (or (eq? err _econnrefused) (eq? err _etimedout) 630 (eq? err _enetunreach) (eq? err _ehostunreach))) 631 (let ((s (socket-fileno so)) 632 (timeout (socket-connect-timeout))) 633 (when (eq? -1 (_connect s (sockaddr-blob saddr) (sockaddr-len saddr))) 634 (let ((err errno)) 635 (if (or (eq? err _einprogress) 636 (eq? err _ewouldblock)) 637 (begin 638 (cond-expand 639 (windows ;; WINSOCK--connect failure returned in exceptfds; manually schedule 640 (let ((wait (busy-timeout (or timeout +largest-fixnum+)))) ;; 12.4 days on 32bit 641 (let loop ((n 0)) 642 (let ((f (select-for-write-or-except s))) 643 (cond ((eq? f -1) 644 (network-error/errno 'socket-connect "select failed" so)) 645 ((eq? f 0) 646 (if (wait so n) 647 (loop (+ n 1)) 648 (socket-timeout-error 'socket-connect timeout so))) 649 ;; else f=1, fall through 650 ))))) 651 (else ;; POSIX--connect failure returned in writefds 652 (let ((f (select-for-write s))) ;; May be ready immediately; don't reschedule. 653 (cond ((eq? f -1) 654 (network-error/errno 'socket-connect "select failed" so)) 655 ((eq? f 0) 656 (block-for-timeout! 'socket-connect timeout s #:output 657 (lambda () (_close_socket s)))) 658 ;; else f=1, fall through 659 )))) 660 (cond ((get-socket-error s) 661 => (lambda (err) 662 (_close_socket s) 663 ((if (refused? err) 664 transient-network-error/errno* 665 network-error/errno*) 666 'socket-connect err "cannot initiate connection" 667 so saddr))))) 668 (begin 669 (_close_socket s) 670 ((if (refused? err) 671 transient-network-error/errno* 672 network-error/errno*) 673 'socket-connect err "cannot initiate connection" so saddr))))) 674 ;; perhaps socket address should be stored in socket object 675 (void))) 676 677;; Sequentially connect to all addrinfo objects until one succeeds, as long 678;; as the connection is retryable (e.g. refused, no route, or timeout). 679;; Otherwise it will error out on non-recoverable errors. 680;; Returns: fresh socket associated with the succeeding connection, or throws 681;; an error corresponding to the last failed connection attempt. 682;; Example: (socket-connect/ai (address-information "localhost" 22 type: sock/stream)) 683;; NB: Connection to sock/dgram will generally succeed, so to ensure TCP connection, 684;; make sure to specify sock/stream. 685;; NB: On Windows XP, a 0 value for socket type will default to TCP (no matter the 686;; value of protocol). address-information returns 0 for type and protocol when 687;; not specified. For safety, you should always provide "type:" or specify a 688;; service name (not port). 689(define (socket-connect/ai ais) 690 (when (null? ais) 691 (network-error 'socket-connect/ai "no addresses to connect to")) 692 (let loop ((ais ais)) 693 (let* ((ai (car ais)) 694 (addr (addrinfo-address ai)) 695 (so (socket (addrinfo-family ai) (addrinfo-socktype ai) 0))) 696 (if (null? (cdr ais)) 697 (begin (socket-connect so addr) so) 698 (condition-case 699 (begin (socket-connect so addr) so) 700 (e (exn i/o net timeout) 701 (loop (cdr ais))) 702 (e (exn i/o net transient) 703 (loop (cdr ais)))))))) 704 705;; (socket-bind s (addrinfo-address (car (address-information "127.0.0.1" 9112 socktype: sock/stream flags: ai/passive)))) 706;; ... is verbose. 707;; Normal usage is (socket-bind s (inet-address "127.0.0.1" 9112)). 708;; Using (inet-address #f nnn) will bind to the unspecified address, although that 709;; may not match the socket type. 710 711(define (socket-bind so saddr) 712 (define _bind (foreign-lambda int "bind" int scheme-pointer int)) 713 (let ((b (_bind (socket-fileno so) (sockaddr-blob saddr) (sockaddr-len saddr)))) 714 (if (eq? -1 b) 715 (network-error/errno 'socket-bind "cannot bind to socket" so saddr) 716 (void)))) 717 718;; Listening on datagram socket throws an OS error. 719(define (socket-listen so backlog) 720 (define _listen (foreign-lambda int "listen" int int)) 721 (let ((l (_listen (socket-fileno so) backlog))) 722 (when (eq? -1 l) 723 (network-error/errno 'socket-listen "cannot listen on socket" so)))) 724 725(define (socket-close so) 726 (let ((s (socket-fileno so))) 727 (when (fx= -1 (_close_socket s)) 728 (network-error/errno 'socket-close "could not close socket" so)))) 729 730(define (socket-close* so) ;; Close socket, ignoring any error. 731 (_close_socket (socket-fileno so)) 732 (void)) 733 734;; Returns a socket object representing the accepted connection. 735;; Does not currently return the socket address of the remote, although it could; 736;; alternatively you can get it from getpeername. 737(define (socket-accept so) 738 (define _accept (foreign-lambda int "accept" int c-pointer c-pointer)) 739 (let ((s (socket-fileno so)) 740 (to (socket-accept-timeout))) 741 (let restart () 742 (let ((f (select-for-read s))) 743 (cond 744 ((eq? f -1) 745 (network-error/errno 'socket-accept "select failed" so)) 746 ((eq? f 1) 747 (let ((s (_accept s #f #f))) 748 (when (eq? -1 s) 749 (network-error/errno 'socket-accept "could not accept from listener" so)) 750 (let ((so (make-socket s (socket-family so) (socket-type so) (socket-protocol so)))) 751 (unless (_make_socket_nonblocking s) 752 (network-error/errno 'socket-accept "unable to set socket to non-blocking" so)) 753 so))) 754 (else 755 (block-for-timeout! 'socket-accept to s #:input) 756 (restart))))))) 757 758;; Returns number of bytes received. If 0, and socket is sock/stream, peer has shut down his side. 759(define (socket-receive! so buf #!optional (start 0) (end #f) (flags 0)) 760 (let* ((buflen (cond ((string? buf) (string-length buf)) 761 ((blob? buf) (blob-size buf)) 762 (else 763 (network-error 'socket-receive! 764 "receive buffer must be a blob or a string" so)))) 765 (end (or end buflen))) 766 (check-socket so 'socket-receive!) 767 (##sys#check-exact start) 768 (##sys#check-exact end) 769 (##sys#check-exact flags) 770 (when (or (fx< start 0) 771 (fx> end buflen) 772 (fx< end start)) 773 (network-error 'socket-receive! "receive buffer offsets out of range" start end)) 774 (%socket-receive! so buf start (fx- end start) flags (socket-receive-timeout)))) 775 776;; Variant of socket-receive! which does not check so, buf, start, or len and which takes 777;; read timeout as parameter. Basically for use in socket ports. 778(define (%socket-receive! so buf start len flags timeout) 779 (define _recv_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start) 780 (int len) (int flags)) 781 "C_return(recv(s,((char*)buf)+start,len,flags));")) 782 (let ((s (%socket-fileno so))) 783 (let restart () 784 (let ((n (_recv_offset s buf start len flags))) 785 (cond ((eq? -1 n) 786 (let ((err errno)) 787 (cond ((eq? err _ewouldblock) 788 (block-for-timeout! 'socket-receive! timeout s #:input) 789 (restart)) 790 (else 791 (network-error/errno* 'socket-receive! err "cannot read from socket" so))))) 792 (else n)))))) 793 794;; Receive up to LEN bytes from socket and return as a string. 795;; TODO: Each socket or perhaps thread should have a dedicated input buffer which is 796;; equal to the largest LEN ever given here, to avoid excessive allocation. 797;; TODO: Should LEN default to socket-receive-buffer-size ? 798(define (socket-receive so len #!optional (flags 0)) 799 (let ((buf (make-string len))) ; checks len exact 800 (check-socket so 'socket-receive) 801 (##sys#check-exact flags) 802 (let ((n (%socket-receive! so buf 0 len flags (socket-receive-timeout)))) 803 (if (= len n) 804 buf 805 (substring buf 0 n))))) 806 807;; Returns 2 values: number of bytes received, and socket address from which they were 808;; received. 809;; NB Cut-and-paste from socket-receive! -- not clear whether we can safely 810;; use recvfrom with NULL socket address to simulate recv() on all platforms. 811(define (socket-receive-from! so buf #!optional (start 0) (end #f) (flags 0)) 812 (let* ((buflen (cond ((string? buf) (string-length buf)) 813 ((blob? buf) (blob-size buf)) 814 (else 815 (network-error 'socket-receive-from! 816 "receive buffer must be a blob or a string" so)))) 817 (end (or end buflen))) 818 (check-socket so 'socket-receive-from!) 819 (##sys#check-exact start) 820 (##sys#check-exact end) 821 (##sys#check-exact flags) 822 (when (or (fx< start 0) 823 (fx> end buflen) 824 (fx< end start)) 825 (network-error 'socket-receive-from! "receive buffer offsets out of range" start end)) 826 (let ((R (%socket-receive-from! so buf start (fx- end start) flags (socket-receive-timeout)))) 827 (values (car R) (cdr R))))) 828 829(define (%socket-receive-from! so buf start len flags timeout) 830 (define _recvfrom_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start) 831 (int len) (int flags) 832 (scheme-pointer addr) ((c-pointer int) addrlen)) 833 "C_return(recvfrom(s,((char*)buf)+start,len,flags,addr,addrlen));")) 834 (let-location ((addrlen int _sockaddr_storage_size)) 835 (let ((s (%socket-fileno so)) 836 (addr (make-blob _sockaddr_storage_size))) 837 (let restart () 838 (let ((n (_recvfrom_offset s buf start len flags addr (location addrlen)))) 839 (cond ((eq? -1 n) 840 (let ((err errno)) 841 (cond ((eq? err _ewouldblock) 842 (block-for-timeout! 'socket-receive! timeout s #:input) 843 (restart)) 844 (else 845 (network-error/errno* 'socket-receive! err "cannot read from socket" so))))) 846 (else 847 (cons n 848 (sa->sockaddr (location addr) addrlen))))))))) 849 850(define (unix-address path) 851 (cond-expand 852 (AF_UNIX 853 (define _make_unix_sa 854 (foreign-lambda* c-pointer ((nonnull-c-string path)) 855 "struct sockaddr_un *addr; " 856 "addr = C_malloc(sizeof *addr);" 857 "memset(addr,0,sizeof *addr);" 858 "addr->sun_family = AF_UNIX;" 859 "strncpy(addr->sun_path, path, sizeof addr->sun_path - 1);" 860 "addr->sun_path[sizeof addr->sun_path - 1] = '\\0';" 861 "C_return(addr);")) 862 (define _free (foreign-lambda void "C_free" c-pointer)) 863 (let ((sa (_make_unix_sa path))) 864 (let ((addr (sa->sockaddr sa (foreign-value "sizeof(struct sockaddr_un)" int)))) 865 (_free sa) 866 addr))) 867 (else 868 (error 'unix-address "unix sockets are not supported on this platform")))) 869 870;; Receive up to LEN bytes from unconnected socket and return 2 values: 871;; the received string and the socket address from whence it came. 872;; See TODOs at socket-receive. 873(define (socket-receive-from so len #!optional (flags 0)) 874 (let ((buf (make-string len))) ; checks len exact 875 (check-socket so 'socket-receive-from) 876 (##sys#check-exact flags) 877 (let ((R (%socket-receive-from! so buf 0 len flags (socket-receive-timeout)))) 878 (let ((n (car R))) 879 (values (if (= len n) buf (substring buf 0 n)) 880 (cdr R)))))) 881 882(define (socket-receive-ready? so) 883 (let ((f (select-for-read (socket-fileno so)))) 884 (when (eq? -1 f) 885 (network-error/errno 'socket-receive-ready? "unable to check socket for input" so)) 886 (eq? 1 f))) 887(define socket-accept-ready? socket-receive-ready?) 888 889(define (socket-send so buf #!optional (start 0) (end #f) (flags 0)) 890 (let* ((buflen (cond ((string? buf) (string-length buf)) 891 ((blob? buf) (blob-size buf)) 892 (else 893 (network-error 'socket-send 894 "send buffer must be a blob or a string" so)))) 895 (end (or end buflen))) 896 (check-socket so 'socket-send) 897 (##sys#check-exact start) 898 (##sys#check-exact end) 899 (##sys#check-exact flags) 900 (when (or (fx< start 0) 901 (fx> end buflen) 902 (fx< end start)) 903 (network-error 'socket-send "send buffer offsets out of range" start end)) 904 (%socket-send so buf start (fx- end start) flags (socket-send-timeout)))) 905(define (%socket-send so buf start len flags timeout) 906 (define _send_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start) 907 (int len) (int flags)) 908 "C_return(send(s,((char*)buf)+start,len,flags));")) 909 (let ((s (%socket-fileno so))) 910 (let retry ((len len) (start start)) 911 (let ((n (_send_offset s buf start len flags))) 912 (cond ((eq? -1 n) 913 (let ((err errno)) 914 (cond ((eq? err _ewouldblock) 915 (block-for-timeout! 'socket-send timeout s #:output) 916 (retry len start)) 917 (else 918 (network-error/errno* 'socket-send err "cannot send to socket" so))))) 919 (else n)))))) 920 921;; Socket output chunk size for send-all. For compatibility with Unit TCP; maybe not necessary. 922;; If #f, attempt to send as much as possible. Only question is whether it is safe to exceed 923;; the socket send buffer size, which may (according to Microsoft pages) cause stalling until 924;; delayed ACKs come back. 925(define socket-send-size (make-parameter 16384)) 926(define socket-send-buffer-size (make-parameter #f)) 927;;(define socket-receive-size (make-parameter 1024)) ;;? 928(define socket-receive-buffer-size (make-parameter 4096)) 929 930(define-foreign-variable +maximum-string-length+ int "C_HEADER_SIZE_MASK") ;; horrible 931(define (%socket-send-all so buf start slen flags timeout chunksz) 932 (let ((chunksz (or chunksz +maximum-string-length+))) 933 (let loop ((len slen) (start start)) 934 (let* ((count (fxmin chunksz len)) 935 (n (%socket-send so buf start count flags timeout))) 936 (if (fx< n len) 937 (loop (fx- len n) (fx+ start n)) 938 (void)))))) 939 940(define (socket-send-all so buf #!optional (start 0) (end #f) (flags 0)) 941 (let* ((buflen (cond ((string? buf) (string-length buf)) 942 ((blob? buf) (blob-size buf)) 943 (else 944 (network-error 'socket-send-all 945 "send buffer must be a blob or a string" so)))) 946 (end (or end buflen))) 947 (check-socket so 'socket-send-all) 948 (##sys#check-exact start) 949 (##sys#check-exact end) 950 (##sys#check-exact flags) 951 (when (or (fx< start 0) 952 (fx> end buflen) 953 (fx< end start)) 954 (network-error 'socket-send-all "send buffer offsets out of range" start end)) 955 (%socket-send-all so buf start (fx- end start) flags 956 (socket-send-timeout) 957 (socket-send-size)))) 958 959;; Like socket-send, but used for connectionless protocols; sends to non-connected 960;; address SADDR. 961(define (socket-send-to so buf saddr #!optional (start 0) (end #f) (flags 0)) 962 (let* ((buflen (cond ((string? buf) (string-length buf)) 963 ((blob? buf) (blob-size buf)) 964 (else 965 (network-error 'socket-send-to 966 "send buffer must be a blob or a string" so)))) 967 (end (or end buflen))) 968 (check-socket so 'socket-send-to) 969 (##sys#check-exact start) 970 (##sys#check-exact end) 971 (##sys#check-exact flags) 972 (when (or (fx< start 0) 973 (fx> end buflen) 974 (fx< end start)) 975 (network-error 'socket-send-to "send buffer offsets out of range" start end)) 976 (%socket-send-to so buf saddr start (fx- end start) flags (socket-send-timeout)))) 977(define (%socket-send-to so buf saddr start len flags timeout) 978 (define _sendto_offset (foreign-lambda* int ((int s) (scheme-pointer buf) 979 (int start) (int len) (int flags) 980 (scheme-pointer addr) (int addrlen)) 981 "C_return(sendto(s,((char*)buf)+start,len,flags,addr,addrlen));")) 982 (let ((s (%socket-fileno so)) 983 (addr (sockaddr-blob saddr)) ;; maybe pull this out into caller 984 (addrlen (sockaddr-len saddr))) 985 (let retry ((len len) (start start)) 986 (let ((n (_sendto_offset s buf start len flags addr addrlen))) 987 (cond ((eq? -1 n) 988 (let ((err errno)) 989 (cond ((eq? err _ewouldblock) 990 (block-for-timeout! 'socket-send-to timeout s #:output) 991 (retry len start)) 992 (else 993 (network-error/errno* 'socket-send-to err "cannot send to socket" so saddr))))) 994 (else n)))))) 995 996 997;; Shutdown socket. If socket is not connected, silently ignore the error, because 998;; the peer may have already initiated shutdown. That behavior should perhaps be configurable. 999(define (socket-shutdown so how) ;; how: shut/rd, shut/wr, shut/rdwr 1000 (define _shutdown (foreign-lambda int "shutdown" int int)) 1001 (when (eq? -1 (_shutdown (socket-fileno so) how)) 1002 (let ((err errno)) 1003 (unless (eq? err _enotconn) 1004 (network-error/errno* 'socket-shutdown err "unable to shutdown socket" so how)))) 1005 (void)) 1006 1007;; Return #f for unbound socket. On Windows, must test WSAEINVAL. 1008;; On UNIX, testing for port 0 should be sufficient. 1009;; UNIX sockets don't have a name; just return #f. 1010(define (socket-name so) ;; a legacy name 1011 (define _free (foreign-lambda void "C_free" c-pointer)) 1012 (cond #? (AF_UNIX 1013 ((eq? (socket-family so) AF_UNIX) #f) 1014 (#f #f)) 1015 (else 1016 (let-location ((len int)) 1017 (let ((sa (_getsockname (socket-fileno so) (location len)))) 1018 (let ((err errno)) 1019 (cond (sa 1020 (let ((addr (sa->sockaddr sa len))) 1021 (_free sa) 1022 (if (= 0 (sockaddr-port addr)) 1023 #f 1024 addr))) 1025 (else 1026 (if (cond-expand (windows (eq? err _einval)) 1027 (else #f)) 1028 #f 1029 (network-error/errno 'socket-name "unable to get socket name" so)))))))))) 1030 1031(define (socket-peer-name so) 1032 (define _free (foreign-lambda void "C_free" c-pointer)) 1033 (let-location ((len int)) 1034 (let ((sa (_getpeername (socket-fileno so) (location len)))) 1035 (let ((err errno)) 1036 (if sa 1037 (let ((addr (sa->sockaddr sa len))) 1038 (_free sa) 1039 addr) 1040 (if (eq? err _enotconn) 1041 #f 1042 (network-error/errno* 'socket-peer-name err 1043 "unable to get socket peer name" so))))))) 1044 1045(define _getsockname 1046 (foreign-lambda* c-pointer ((int s) ((c-pointer int) len)) 1047 "struct sockaddr_storage *ss;" 1048 "ss = (struct sockaddr_storage *)C_malloc(sizeof(*ss));" 1049 "*len = sizeof(*ss);" 1050 "if (getsockname(s, (struct sockaddr *)ss, (socklen_t *)len) != 0) C_return(NULL);" 1051 "C_return(ss);")) 1052(define _getpeername 1053 (foreign-lambda* c-pointer ((int s) ((c-pointer int) len)) 1054 "struct sockaddr_storage *ss;" 1055 "ss = (struct sockaddr_storage *)C_malloc(sizeof(*ss));" 1056 "*len = sizeof(*ss);" 1057 "if (getpeername(s, (struct sockaddr *)ss, (socklen_t *)len) != 0) C_return(NULL);" 1058 "C_return(ss);")) 1059 1060 1061;;; socket options 1062 1063(include "socket-options.scm") 1064 1065;;; ports 1066 1067;; FIXME: port->fileno calls ##sys#tcp-port->fileno and requires the TCP 1068;; core unit to be loaded. Theoretically, we could define this ourselves, 1069;; and avoid this crap with compatible socket ports. However, this would 1070;; require tcp to be loaded first so it does not overwrite our export. 1071;; Also keep in mind it cannot be defined inside a module. 1072 1073;; We unfortunately must maintain compatibility with Unit tcp ports so 1074;; that port->fileno works (relied on by, e.g., sendfile). Thus we 1075;; must have port of type 'socket and vector port data containing the 1076;; fileno as slot 0. So procedures in Unit TCP that take ports will 1077;; accept our ports and possibly crash :( However, we can avoid taking 1078;; TCP ports here by adding unique data to the end of the structure. 1079(define-inline (socket-port-data p) 1080 (or (and (eq? (##sys#slot p 7) 'socket) 1081 (let ((d (##sys#port-data p))) 1082 (and (vector? d) 1083 (= (vector-length d) 7) 1084 (eq? (##sys#slot d 5) 'socket6) 1085 d))) 1086 (type-error 'socket-port-data "argument is not a socket port" p))) 1087 1088(define-inline (%socket-port-data-socket data) (##sys#slot data 6)) 1089(define-inline (%socket-port-data-input-abandoned? data) (##sys#slot data 1)) 1090(define-inline (%socket-port-data-output-abandoned? data) (##sys#slot data 2)) 1091 1092(define (socket-i/o-port->socket p) 1093 (%socket-port-data-socket (socket-port-data p))) 1094 1095(define socket-i/o-ports 1096 (lambda (so) 1097 (let* ((fd (socket-fileno so)) 1098 (input-buffer-size (socket-receive-buffer-size)) 1099 (buf (make-string input-buffer-size)) 1100 (data (vector fd #f #f buf 0 'socket6 so)) 1101 (buflen 0) 1102 (bufindex 0) 1103 (iclosed #f) 1104 (oclosed #f) 1105 (outbufsize (socket-send-buffer-size)) 1106 (outbuf (and outbufsize (fx> outbufsize 0) 1107 (make-string outbufsize))) 1108 (outbufindex 0) 1109 (tmr (socket-receive-timeout)) 1110 (tmw (socket-send-timeout)) 1111 (output-chunk-size (socket-send-size)) 1112 (read-input 1113 (lambda () 1114 (let ((n (%socket-receive! so buf 0 input-buffer-size 0 tmr))) 1115 (set! buflen n) 1116 (##sys#setislot data 4 n) 1117 (set! bufindex 0)))) 1118 (in 1119 (make-input-port 1120 (lambda () 1121 (when (fx>= bufindex buflen) 1122 (read-input)) 1123 (if (fx>= bufindex buflen) 1124 #!eof 1125 (let ((c (##core#inline "C_subchar" buf bufindex))) 1126 (set! bufindex (fx+ bufindex 1)) 1127 c) ) ) 1128 (lambda () 1129 (or (fx< bufindex buflen) 1130 (socket-receive-ready? so))) 1131 (lambda () 1132 (unless iclosed 1133 (set! iclosed #t) 1134 (unless (%socket-port-data-input-abandoned? data) ;; Skip this for dgram? 1135 (socket-shutdown so shut/rd)) ;; Must not error if peer has shutdown. 1136 (when oclosed 1137 (socket-close so)))) 1138 (lambda () 1139 (when (fx>= bufindex buflen) 1140 (read-input)) 1141 (if (fx< bufindex buflen) 1142 (##core#inline "C_subchar" buf bufindex) 1143 #!eof)) 1144 (lambda (p n dest start) ; read-string! 1145 (let loop ((n n) (m 0) (start start)) 1146 (cond ((eq? n 0) m) 1147 ((fx< bufindex buflen) 1148 (let* ((rest (fx- buflen bufindex)) 1149 (n2 (if (fx< n rest) n rest))) 1150 (##core#inline "C_substring_copy" buf dest bufindex (fx+ bufindex n2) start) 1151 (set! bufindex (fx+ bufindex n2)) 1152 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ) 1153 (else 1154 (read-input) 1155 (if (eq? buflen 0) 1156 m 1157 (loop n m start) ) ) ) ) ) 1158 #-scan-buffer-line-returns-3-vals 1159 (lambda (p limit) ; read-line 1160 (let loop ((str #f) 1161 (limit (or limit (##sys#fudge 21)))) 1162 (cond ((fx< bufindex buflen) 1163 (##sys#scan-buffer-line 1164 buf 1165 (fxmin buflen limit) 1166 bufindex 1167 (lambda (pos2 next) 1168 (let* ((len (fx- pos2 bufindex)) 1169 (dest (##sys#make-string len))) 1170 (##core#inline "C_substring_copy" buf dest bufindex pos2 0) 1171 (set! bufindex next) 1172 (cond ((eq? pos2 limit) ; no line-terminator, hit limit 1173 (if str (##sys#string-append str dest) dest)) 1174 ((eq? pos2 next) ; no line-terminator, hit buflen 1175 (read-input) 1176 (if (fx>= bufindex buflen) 1177 (or str "") 1178 (loop (if str (##sys#string-append str dest) dest) 1179 (fx- limit len)) ) ) 1180 (else 1181 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1)) 1182 (if str (##sys#string-append str dest) dest)) ) ) ) ) ) 1183 (else 1184 (read-input) 1185 (if (fx< bufindex buflen) 1186 (loop str limit) 1187 #!eof) ) ) ) ) 1188 #+scan-buffer-line-returns-3-vals 1189 (lambda (p limit) ; read-line 1190 (when (fx>= bufindex buflen) 1191 (read-input)) 1192 (if (fx>= bufindex buflen) 1193 #!eof 1194 (let ((limit (or limit (fx- (##sys#fudge 21) bufindex)))) 1195 (receive (next line full-line?) 1196 (##sys#scan-buffer-line 1197 buf 1198 (fxmin buflen (fx+ bufindex limit)) 1199 bufindex 1200 (lambda (pos) 1201 (let ((nbytes (fx- pos bufindex))) 1202 (cond ((fx>= nbytes limit) 1203 (values #f pos #f)) 1204 (else (read-input) 1205 (set! limit (fx- limit nbytes)) 1206 (if (fx< bufindex buflen) 1207 (values buf bufindex 1208 (fxmin buflen 1209 (fx+ bufindex limit))) 1210 (values #f bufindex #f))))) ) ) 1211 ;; Update ro…
Large files files are truncated, but you can click here to view the full file