PageRenderTime 8ms CodeModel.GetById 6ms app.highlight 71ms RepoModel.GetById 1ms app.codeStats 1ms

/socket.scm

https://bitbucket.org/ursetto/rfc2553
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