/socket.scm
Scheme | 1340 lines | 1038 code | 105 blank | 197 comment | 13 complexity | 80541bfb732657d98db8edfb590ef9d4 MD5 | raw file
- ;;; socket extension
- ;;; License
- ;; Some code was derived from Chicken core tcp.scm.
- ;; Copyright (c) 2011-2012, Jim Ursetto
- ;; Copyright (c) 2008-2011, The Chicken Team
- ;; Copyright (c) 2000-2007, Felix L. Winkelmann
- ;; All rights reserved.
- ;; Redistribution and use in source and binary forms, with or without
- ;; modification, are permitted provided that the following conditions
- ;; are met:
- ;; - Redistributions of source code must retain the above copyright
- ;; notice, this list of conditions and the following disclaimer.
- ;; - Redistributions in binary form must reproduce the above copyright
- ;; notice, this list of conditions and the following disclaimer in
- ;; the documentation and/or other materials provided with the
- ;; distribution.
- ;; - Neither the name of the author nor the names of its contributors
- ;; may be used to endorse or promote products derived from this
- ;; software without specific prior written permission.
- ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- ;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
- ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
- ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
- ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
- ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
- ;; OF THE POSSIBILITY OF SUCH DAMAGE.
- (import scheme (except chicken errno) foreign)
- (use foreigners)
- (use srfi-4 extras ports)
- (use (only srfi-13 string-index))
- ;; Pull TCP in w/o importing so ##sys#tcp-port->fileno is defined
- ;; and network is started up.
- (require-library tcp)
- #> #include "socket.h" <#
- ;;; error handling
- (define-foreign-variable errno int "errno")
- (define strerror (foreign-lambda c-string "skt_strerror" int))
- (define-inline (type-error where msg . args)
- (apply ##sys#signal-hook #:type-error where msg args))
- (define-inline (domain-error where msg . args)
- (apply ##sys#signal-hook #:domain-error where msg args))
- (define-inline (network-error where msg . args)
- (apply ##sys#signal-hook #:network-error where msg args))
- (define-inline (network-error/errno where msg . args)
- (let ((err errno))
- (##sys#update-errno) ;; Note that this may cause context switch, and wipe out errno
- (apply ##sys#signal-hook #:network-error where
- (string-append msg " - " (strerror err))
- args)))
- (define-inline (network-error/errno* where err msg . args)
- ;;(##sys#update-errno)
- (apply ##sys#signal-hook #:network-error where
- (string-append msg " - " (strerror err))
- args))
- (define-inline (transient-network-error/errno* where err msg . args)
- (abort
- (make-composite-condition
- (make-property-condition 'exn 'location where
- 'message (string-append msg " - " (strerror err))
- 'arguments args)
- (make-property-condition 'i/o)
- (make-property-condition 'net 'errno err)
- (make-property-condition 'transient))))
- (define-inline (unsupported-error where msg . args)
- (abort
- (make-composite-condition
- (make-property-condition 'exn 'location where
- 'message msg
- 'arguments args)
- (make-property-condition 'i/o)
- (make-property-condition 'net)
- (make-property-condition 'unsupported))))
- ;;; constants
- ;; (define-foreign-flag AI_NUMERICSERV) =>
- ;; (begin (foreign-declare "#ifndef AI_NUMERICSERV\n#define AI_NUMERICSERV 0\n#endif\n")
- ;; (define-foreign-variable AI_NUMERICSERV int "AI_NUMERICSERV")
- ;; (define-for-syntax (c-name sym)
- ;; (string-translate (string-upcase (symbol->string sym)) "/" "_"))
- (define-syntax define-foreign-flag
- (lambda (e r c)
- (let ((name (cadr e)))
- `(,(r 'begin)
- (,(r 'foreign-declare)
- ,(sprintf "#ifndef ~A\n#define ~A 0\n#endif\n" name name))
- (,(r 'define-foreign-variable) ,name ,(r 'int) ,(symbol->string name))))))
- (define-foreign-enum-type (address-family int)
- (address-family->integer integer->address-family)
- ((af/unspec AF_UNSPEC) AF_UNSPEC)
- ((af/inet AF_INET) AF_INET)
- ((af/inet6 AF_INET6) AF_INET6)
- ;; #+AF_UNIX ((af/unix AF_UNIX) AF_UNIX)
- )
- #+AF_UNIX (define-foreign-variable AF_UNIX int AF_UNIX)
- (define af/unspec AF_UNSPEC)
- (define af/inet AF_INET)
- (define af/inet6 AF_INET6)
- (define af/unix #? (AF_UNIX AF_UNIX #f))
- (define-foreign-enum-type (socket-type int)
- (socket-type->integer integer->socket-type)
- ((sock/stream SOCK_STREAM) SOCK_STREAM)
- ((sock/dgram SOCK_DGRAM) SOCK_DGRAM)
- ((sock/raw SOCK_RAW) SOCK_RAW))
- (define sock/stream SOCK_STREAM)
- (define sock/dgram SOCK_DGRAM)
- (define sock/raw SOCK_RAW)
- ;; These are for address-information, not socket options -- so TCP and UDP only.
- (define-foreign-enum-type (protocol-type int)
- (protocol-type->integer integer->protocol-type)
- ((ipproto/tcp IPPROTO_TCP) IPPROTO_TCP)
- ((ipproto/udp IPPROTO_UDP) IPPROTO_UDP))
- (define ipproto/tcp IPPROTO_TCP)
- (define ipproto/udp IPPROTO_UDP)
- (define-foreign-variable AI_CANONNAME int "AI_CANONNAME")
- (define ai/canonname AI_CANONNAME)
- (define-foreign-variable AI_NUMERICHOST int "AI_NUMERICHOST")
- (define ai/numerichost AI_NUMERICHOST)
- (define-foreign-variable AI_PASSIVE int "AI_PASSIVE")
- (define ai/passive AI_PASSIVE)
- ;; These flags will be set to 0 if undefined. The ones above
- ;; will throw a compilation error since they are required.
- (define-foreign-flag AI_NUMERICSERV)
- (define ai/numericserv AI_NUMERICSERV)
- (define-foreign-flag AI_ALL)
- (define ai/all AI_ALL)
- (define-foreign-flag AI_V4MAPPED)
- (define ai/v4mapped AI_V4MAPPED)
- (define-foreign-flag AI_ADDRCONFIG)
- (define ai/addrconfig AI_ADDRCONFIG)
- (define-foreign-flag AI_MASK)
- (define ai/mask AI_MASK)
- (define-foreign-flag AI_DEFAULT)
- (define ai/default AI_DEFAULT)
- (define-foreign-variable NI_MAXHOST int "NI_MAXHOST")
- (define-foreign-variable NI_MAXSERV int "NI_MAXSERV")
- (define-foreign-variable NI_NUMERICHOST int "NI_NUMERICHOST")
- (define-foreign-variable NI_NUMERICSERV int "NI_NUMERICSERV")
- (define-foreign-variable NI_DGRAM int "NI_DGRAM")
- (define-foreign-variable NI_NAMEREQD int "NI_NAMEREQD")
- (define-foreign-variable NI_NOFQDN int "NI_NOFQDN")
- (define ni/numerichost NI_NUMERICHOST)
- (define ni/numericserv NI_NUMERICSERV)
- (define ni/dgram NI_DGRAM)
- (define ni/namereqd NI_NAMEREQD)
- (define ni/nofqdn NI_NOFQDN)
- ;;;
- (define-foreign-record-type (sa "struct sockaddr")
- (int sa_family sa-family))
- (define-foreign-variable _sockaddr_storage_size int "sizeof(struct sockaddr_storage)")
- (define-record sockaddr family blob)
- (define (sa->sockaddr sa len) ;; sa -- c-pointer; len -- length of sockaddr struct
- (if (= len 0) ;; for example, socket-receive-from! returns 0 len on connection-oriented socket
- #f
- (make-sockaddr (sa-family sa) ;; Assume when len > 0, it at least includes the family.
- (let ((b (make-blob len)))
- ((foreign-lambda void C_memcpy scheme-pointer c-pointer int)
- b sa len)
- b))))
- (define (sockaddr-len A)
- (blob-size (sockaddr-blob A)))
- (define (sockaddr-address A)
- (let ((af (sockaddr-family A)))
- (cond ((or (= af AF_INET)
- (= af AF_INET6))
- (car (getnameinfo A (+ NI_NUMERICHOST NI_NUMERICSERV))))
- #? (AF_UNIX
- ((= af AF_UNIX) (sockaddr-path A))
- (#f #f))
- (else #f))))
- ;; Port and path will return #f if called on the wrong sockaddr type.
- ;; Maybe throw an error instead?
- (define (sockaddr-port A)
- (or
- ((foreign-lambda* scheme-object ((scheme-pointer sa))
- "switch (((struct sockaddr*)sa)->sa_family) {"
- "case AF_INET: C_return(C_fix(ntohs(((struct sockaddr_in*)sa)->sin_port)));"
- "case AF_INET6: C_return(C_fix(ntohs(((struct sockaddr_in6*)sa)->sin6_port)));"
- "default: C_return(C_SCHEME_FALSE); }")
- (sockaddr-blob A))
- (network-error 'sockaddr-port "unable to obtain port for socket address" A)))
- (define (sockaddr-path A)
- #? (AF_UNIX
- (or
- ((foreign-lambda* c-string ((scheme-pointer sa))
- "switch (((struct sockaddr*)sa)->sa_family) {"
- "case AF_UNIX: C_return(((struct sockaddr_un*)sa)->sun_path);"
- "default: C_return(NULL); }"
- )
- (sockaddr-blob A))
- (network-error 'sockaddr-path "unable to obtain path for socket address" A))
- (error 'sockaddr-path "UNIX sockets are not supported")))
- (define-record-printer (sockaddr A out)
- (fprintf out "#<sockaddr ~S>"
- (sockaddr->string A)
- ;; (integer->address-family (sockaddr-family A))
- ))
- ;; Convert socket address/path to a compact string, mainly for display purposes.
- (define (sockaddr->string A)
- (let ((af (sockaddr-family A)))
- (cond ((or (= af AF_INET)
- (= af AF_INET6))
- (let* ((ni (getnameinfo A (+ NI_NUMERICHOST NI_NUMERICSERV)))
- (h (car ni))
- (p (cdr ni)))
- (if (string=? p "0")
- h
- (if (= af AF_INET6)
- (string-append "[" h "]" ":" p)
- (string-append h ":" p)))))
- #?(AF_UNIX
- ((= af AF_UNIX)
- (sockaddr-path A)) ;; or reach directly into blob here
- (#f #f))
- (else
- #f))))
- ;; Intent of this is a direct call to getnameinfo ala inet_ntop, returning
- ;; a plain string; however, error handling is hard.
- ;; (define (sockaddr->ip-string A)
- ;; (foreign-lambda* c-string ((scheme-pointer sa))
- ;; ""
- ;; ))
- (define-foreign-record-type (ai "struct addrinfo")
- (constructor: alloc-ai)
- (destructor: free-ai) ; similar name!
- (int ai_flags ai-flags set-ai-flags!)
- (int ai_family ai-family set-ai-family!)
- (int ai_socktype ai-socktype set-ai-socktype!)
- (int ai_protocol ai-protocol set-ai-protocol!)
- (int ai_addrlen ai-addrlen)
- ((c-pointer sa) ai_addr ai-addr) ;; non-null?
- (c-string ai_canonname ai-canonname)
- ((c-pointer ai) ai_next ai-next))
- (define-syntax non-nil
- (syntax-rules ()
- ((_ a)
- (let ((x a))
- (if (or (not x) (null? x)) #f x)))
- ((_ a . rest)
- (let ((x a))
- (if (or (not x) (null? x))
- (non-nil . rest)
- x)))))
- (define-record addrinfo
- flags family socktype protocol address canonname)
- (define-record-printer (addrinfo a out)
- (fprintf out "#<addrinfo ~S ~S ~S ~S~A>"
- (sockaddr->string (addrinfo-address a))
- (non-nil (integer->address-family (addrinfo-family a)) (addrinfo-family a))
- (non-nil (integer->socket-type (addrinfo-socktype a)) (addrinfo-socktype a))
- (non-nil (integer->protocol-type (addrinfo-protocol a)) (addrinfo-protocol a))
- (cond ((addrinfo-canonname a)
- => (lambda (cn) (sprintf " canonical: ~S" cn)))
- (else ""))
- ;; (addrinfo-flags a) ;; flag display isn't that interesting
- ))
- (define (ai->addrinfo ai) ;; construct addrinfo obj from ai ptr, with embedded sockaddr obj
- (make-addrinfo
- (ai-flags ai)
- (ai-family ai)
- (ai-socktype ai)
- (ai-protocol ai)
- (ai->sockaddr ai)
- (ai-canonname ai)))
- (define (ai->sockaddr ai) ;; direct construction of sockaddr object from ai pointer
- (and-let* ((addr (ai-addr ai)))
- (sa->sockaddr addr (ai-addrlen ai))))
- (define (ai-list->addrinfo ai) ;; construct addrinfo object list from ai linked list
- (let loop ((ai ai)
- (L '()))
- (if ai
- (loop (ai-next ai)
- (cons (ai->addrinfo ai) L))
- (reverse L))))
- (define (alloc-null-ai)
- (let ((null! (foreign-lambda* void ((ai ai))
- "memset(ai,0,sizeof(*ai));"
- ))
- (ai (alloc-ai)))
- (null! ai)
- ai))
- (define _getaddrinfo
- (foreign-lambda int getaddrinfo c-string c-string ai (c-pointer ai)))
- (define freeaddrinfo
- (foreign-lambda void freeaddrinfo ai))
- (define _getnameinfo
- (foreign-lambda int skt_getnameinfo scheme-pointer int scheme-pointer
- int scheme-pointer int int))
- (define gai_strerror (foreign-lambda c-string "gai_strerror" int))
- (define-foreign-variable eai/noname int "EAI_NONAME")
- ;; FIXME: hints constructor is craaaap
- ;; Returns a c-pointer; must call freeaddrinfo on result once used.
- (define (getaddrinfo/ai node service family socktype protocol flags)
- (let-location ((res c-pointer))
- (let ((hints #f))
- (define hints (alloc-null-ai))
- (when family (set-ai-family! hints family))
- (when socktype (set-ai-socktype! hints socktype))
- (when flags (set-ai-flags! hints flags))
- (when protocol (set-ai-protocol! hints protocol))
- (let ((rc (_getaddrinfo node service hints #$res)))
- (when hints (free-ai hints))
- (cond ((= 0 rc)
- res)
- ((= eai/noname rc) ;; save exceptions for real errors
- #f)
- (else
- (when res (freeaddrinfo res)) ;; correct??
- (network-error 'getaddrinfo (gai_strerror rc) node)))))))
- (define (getaddrinfo node service family socktype protocol flags)
- (let* ((ai (getaddrinfo/ai node service family socktype protocol flags))
- (addrinfo (ai-list->addrinfo ai)))
- (when ai (freeaddrinfo ai))
- addrinfo))
- (define (address-information node service #!key family (type sock/stream) protocol flags)
- (let ((service (if (integer? service) (number->string service) service)))
- (getaddrinfo node service family type protocol flags)))
- ;; Constructor for socket address object from IP address string & SERVICE number.
- ;; The usual way to create such an address is via address-information; this is
- ;; a more efficient shortcut.
- ;; When ip is #f, the socket is considered intended for passive use (bind) and
- ;; the unspecified address will be returned. (Implicitly affects name-information.)
- ;; However, the unspecified address may not be useful, as it will return either
- ;; an inet or inet6 address (which may not match the socket family). To avoid
- ;; this, specify "::" or "0.0.0.0" explicitly.
- ;; TODO: Port range should probably be checked.
- (define (inet-address ip port)
- (let ((port (and port
- (cond ((and (exact? port) (number->string port)))
- (else (domain-error 'inet-address
- "port must be a numeric value or #f" port)))))
- (passive (if ip 0 AI_PASSIVE)))
- (let ((ai (getaddrinfo/ai ip port #f #f #f
- (+ AI_NUMERICHOST passive AI_NUMERICSERV))))
- (unless ai
- (network-error 'inet-address "invalid internet address" ip port))
- (let ((saddr (ai->sockaddr ai)))
- (freeaddrinfo ai)
- saddr))))
- ;; ADDR is either a SOCKADDR object, or an IPv4 or IPv6 string.
- ;; Converts returned port to numeric if possible. Does not convert 0 to #f though.
- ;; Note: Should add AI_NUMERICSERV to getaddrinfo call, but it may not be portable.
- ;; Note: (car (name-information addr flags: ni/numerichost)) ==
- ;; (sockaddr-address (inet-address addr 0)), so there is some redundancy.
- ;; (name-information (inet-address "::1" 0))
- (define (name-information saddr #!optional (flags 0))
- (define (massage ni)
- (cond ((string->number (cdr ni))
- => (lambda (p) (cons (car ni) p)))
- (else ni)))
- (massage (getnameinfo (if (string? saddr) (inet-address saddr #f) saddr)
- flags)))
- (define (getnameinfo saddr flags)
- (let* ((sa (sockaddr-blob saddr))
- (salen (sockaddr-len saddr)))
- (let ((node (make-string NI_MAXHOST))
- (serv (make-string NI_MAXSERV)))
- (let ((rc (_getnameinfo sa salen
- node NI_MAXHOST
- serv NI_MAXSERV flags)))
- (cond ((= rc 0)
- (cons (substring node 0 (string-index node #\nul))
- (substring serv 0 (string-index serv #\nul))))
- (else
- (network-error 'getnameinfo (gai_strerror rc))))))))
- ;;; socket operations
- (define socket-connect-timeout)
- (define socket-receive-timeout)
- (define socket-send-timeout)
- (define socket-accept-timeout)
- (let ()
- (define ((check loc) x)
- (when x (##sys#check-exact x loc))
- x)
- (define minute (fx* 60 1000))
- (set! socket-receive-timeout (make-parameter minute (check 'socket-receive-timeout)))
- (set! socket-send-timeout (make-parameter minute (check 'socket-send-timeout)))
- (set! socket-connect-timeout (make-parameter #f (check 'socket-connect-timeout)))
- (set! socket-accept-timeout (make-parameter #f (check 'socket-accept-timeout))))
- (define-foreign-variable _invalid_socket int "INVALID_SOCKET")
- (define-foreign-variable _ewouldblock int "EWOULDBLOCK")
- (define-foreign-variable _einprogress int "EINPROGRESS")
- (define-foreign-variable _econnrefused int "ECONNREFUSED")
- (define-foreign-variable _etimedout int "ETIMEDOUT")
- (define-foreign-variable _enetunreach int "ENETUNREACH")
- (define-foreign-variable _ehostunreach int "EHOSTUNREACH")
- (define-foreign-variable _enotconn int "ENOTCONN")
- (define-foreign-variable _einval int "EINVAL")
- (define-foreign-variable _enoprotoopt int "ENOPROTOOPT")
- (define-foreign-variable SHUT_RD int "SHUT_RD")
- (define-foreign-variable SHUT_WR int "SHUT_WR")
- (define-foreign-variable SHUT_RDWR int "SHUT_RDWR")
- (define shut/rd SHUT_RD)
- (define shut/wr SHUT_WR)
- (define shut/rdwr SHUT_RDWR)
- (define _close_socket (foreign-lambda int "closesocket" int))
- (define _make_socket_nonblocking
- (foreign-lambda* bool ((int fd))
- "#ifdef _WIN32\n"
- "unsigned long val = 1; C_return(ioctlsocket(fd, FIONBIO, &val) == 0);\n"
- "#else\n"
- "int val = fcntl(fd, F_GETFL, 0);"
- "if(val == -1) C_return(0);"
- "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);\n"
- "#endif\n"))
- (define select-for-read
- (foreign-lambda* int ((int fd))
- "fd_set in;
- struct timeval tm;
- int rv;
- FD_ZERO(&in);
- FD_SET(fd, &in);
- tm.tv_sec = tm.tv_usec = 0;
- rv = select(fd + 1, &in, NULL, NULL, &tm);
- if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
- C_return(rv);") )
- (define select-for-write
- (foreign-lambda* int ((int fd))
- "fd_set out;
- struct timeval tm;
- int rv;
- FD_ZERO(&out);
- FD_SET(fd, &out);
- tm.tv_sec = tm.tv_usec = 0;
- rv = select(fd + 1, NULL, &out, NULL, &tm);
- if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
- C_return(rv);") )
- ;; On Windows, non-blocking connection errors show up in except fds.
- (define select-for-write-or-except
- (foreign-lambda* int ((int fd))
- "fd_set out, exc;
- struct timeval tm;
- int rv;
- FD_ZERO(&out); FD_ZERO(&exc);
- FD_SET(fd, &out); FD_SET(fd, &exc);
- tm.tv_sec = tm.tv_usec = 0;
- rv = select(fd + 1, NULL, &out, &exc, &tm);
- if(rv > 0) { rv = (FD_ISSET(fd, &out) || FD_ISSET(fd, &exc)) ? 1 : 0; }
- C_return(rv);") )
- (define-inline (socket-timeout-error where timeout so)
- (##sys#signal-hook
- #:network-timeout-error
- where "operation timed out" timeout so))
- (define (block-for-timeout! where timeout fd type #!optional cleanup) ;; #f permitted for WHERE
- ;; No exported way to simultaneously wait on either an FD or a timeout event.
- (when timeout
- (##sys#thread-block-for-timeout!
- ##sys#current-thread
- (+ (current-milliseconds) timeout)))
- (##sys#thread-block-for-i/o! ##sys#current-thread fd type)
- (##sys#thread-yield!)
- (when (##sys#slot ##sys#current-thread 13)
- (if cleanup (cleanup))
- (##sys#signal-hook
- #:network-timeout-error
- where "operation timed out" timeout fd)))
- (define (get-socket-error s)
- ;; http://cr.yp.to/docs/connect.html describes alternative ways to retrieve
- ;; non-blocking socket errors.
- (define _getsockerr
- (foreign-lambda* int ((int socket))
- "int err;"
- "int optlen = sizeof(err);"
- "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)"
- "C_return(-1);"
- "C_return(err);"))
- (let ((err (_getsockerr s)))
- (cond ((fx= err 0) #f)
- ((fx> err 0) err)
- (else
- (_close_socket s)
- (network-error/errno 'get-socket-error "unable to obtain socket error code")))))
- ;; Silly parsing of inet address string into host and port.
- ;; Note: if unparsable into host/port, return full string as hostname, and let caller deal with it.
- ;; If host or port is empty, returns #f for that field.
- (define (parse-inet-address str)
- (let ((len (string-length str)))
- (if (= len 0)
- (values "" #f)
- (if (char=? (string-ref str 0) #\[)
- (let ((j (string-index str #\] 1)))
- (if j
- (let* ((host (substring str 1 j))
- (host (if (string=? host "") #f host)))
- (if (= (fx+ j 1) len)
- (values host #f) ;; bracketed address w/o port
- (if (char=? (string-ref str (fx+ j 1)) #\:)
- (let* ((port (substring str (fx+ j 2)))
- (port (if (string=? port "") #f port)))
- (values host port)) ;; bracketed address w/ port
- (values str #f))))
- (values str #f)))
- (let ((j (string-index str #\:)))
- (if j
- (let ((k (string-index str #\: (fx+ j 1))))
- (if k
- (values str #f) ;; a bare IPv6 address
- (let* ((host (substring str 0 j))
- (host (if (string=? host "") #f host))
- (port (substring str (fx+ j 1)))
- (port (if (string=? port "") #f port)))
- (values host port)))) ;; IPv4 address w/port
- (values str #f)) ;; an IPv4 address sans port
- )))))
- (define-record socket fileno family type protocol) ;; NB socket? conflicts with Unit posix
- (define-inline (%socket-fileno so)
- (##sys#slot so 1))
- (define-inline (check-socket so loc)
- (unless (socket? so)
- (type-error loc "argument is not a socket" so)))
- (define-record-printer (socket s out)
- (fprintf out "#<socket fd:~S ~S ~S>"
- (socket-fileno s)
- (non-nil (integer->address-family (socket-family s)) (socket-family s))
- (non-nil (integer->socket-type (socket-type s)) (socket-type s))
- #;(non-nil (integer->protocol-type (socket-protocol s)) (socket-protocol s))
- ))
- (define (socket family socktype #!optional (protocol 0))
- (define _socket (foreign-lambda int "socket" int int int))
- (let ((s (_socket family socktype protocol)))
- (when (eq? _invalid_socket s)
- (network-error/errno 'socket "cannot create socket"
- (non-nil (integer->address-family family) family)
- (non-nil (integer->socket-type socktype) socktype)
- (non-nil (integer->protocol-type protocol) protocol)))
- (let ((so (make-socket s family socktype protocol)))
- ;; Immediately set all sockets in non-blocking mode, even UDP.
- ;; See http://lists.nongnu.org/archive/html/chicken-users/2013-06/msg00062.html
- (unless (_make_socket_nonblocking s)
- (network-error/errno 'socket "unable to set socket to non-blocking" so))
- so)))
- (use srfi-18)
- ;; Stolen from sql-de-lite (itself stolen from sqlite), but modified to respect
- ;; actual elapsed time instead of estimated elapsed time (to mostly avoid scheduling jitter).
- ;; The polling intervals are not altered, only the total elapsed time.
- (define busy-timeout
- (let* ((delays '#(1 2 5 10 15 20 25 25 25 50 50 100))
- (ndelay (vector-length delays)))
- (lambda (ms)
- (cond
- ((< ms 0) (domain-error 'busy-timeout "timeout must be non-negative" ms))
- ((= ms 0) #f)
- (else
- (let ((start (current-milliseconds)))
- (lambda (so count)
- (let* ((delay (vector-ref delays (min count (- ndelay 1))))
- (prior (- (current-milliseconds) start)))
- (let ((delay (if (> (+ prior delay) ms)
- (- ms prior)
- delay)))
- (cond ((<= delay 0) #f)
- (else
- (thread-sleep! (/ delay 1000)) ;; silly division
- #t)))))))))))
- (define-constant +largest-fixnum+ (##sys#fudge 21))
- ;; Returns a special "transient" error (exn i/o net transient) if connection failure
- ;; was due to refusal, network down, etc.; in which case, the same or another
- ;; address could be tried later. (The socket is still closed, though.)
- (define (socket-connect so saddr)
- (define _connect (foreign-lambda int "connect" int scheme-pointer int))
- (define (refused? err)
- (or (eq? err _econnrefused) (eq? err _etimedout)
- (eq? err _enetunreach) (eq? err _ehostunreach)))
- (let ((s (socket-fileno so))
- (timeout (socket-connect-timeout)))
- (when (eq? -1 (_connect s (sockaddr-blob saddr) (sockaddr-len saddr)))
- (let ((err errno))
- (if (or (eq? err _einprogress)
- (eq? err _ewouldblock))
- (begin
- (cond-expand
- (windows ;; WINSOCK--connect failure returned in exceptfds; manually schedule
- (let ((wait (busy-timeout (or timeout +largest-fixnum+)))) ;; 12.4 days on 32bit
- (let loop ((n 0))
- (let ((f (select-for-write-or-except s)))
- (cond ((eq? f -1)
- (network-error/errno 'socket-connect "select failed" so))
- ((eq? f 0)
- (if (wait so n)
- (loop (+ n 1))
- (socket-timeout-error 'socket-connect timeout so)))
- ;; else f=1, fall through
- )))))
- (else ;; POSIX--connect failure returned in writefds
- (let ((f (select-for-write s))) ;; May be ready immediately; don't reschedule.
- (cond ((eq? f -1)
- (network-error/errno 'socket-connect "select failed" so))
- ((eq? f 0)
- (block-for-timeout! 'socket-connect timeout s #:output
- (lambda () (_close_socket s))))
- ;; else f=1, fall through
- ))))
- (cond ((get-socket-error s)
- => (lambda (err)
- (_close_socket s)
- ((if (refused? err)
- transient-network-error/errno*
- network-error/errno*)
- 'socket-connect err "cannot initiate connection"
- so saddr)))))
- (begin
- (_close_socket s)
- ((if (refused? err)
- transient-network-error/errno*
- network-error/errno*)
- 'socket-connect err "cannot initiate connection" so saddr)))))
- ;; perhaps socket address should be stored in socket object
- (void)))
- ;; Sequentially connect to all addrinfo objects until one succeeds, as long
- ;; as the connection is retryable (e.g. refused, no route, or timeout).
- ;; Otherwise it will error out on non-recoverable errors.
- ;; Returns: fresh socket associated with the succeeding connection, or throws
- ;; an error corresponding to the last failed connection attempt.
- ;; Example: (socket-connect/ai (address-information "localhost" 22 type: sock/stream))
- ;; NB: Connection to sock/dgram will generally succeed, so to ensure TCP connection,
- ;; make sure to specify sock/stream.
- ;; NB: On Windows XP, a 0 value for socket type will default to TCP (no matter the
- ;; value of protocol). address-information returns 0 for type and protocol when
- ;; not specified. For safety, you should always provide "type:" or specify a
- ;; service name (not port).
- (define (socket-connect/ai ais)
- (when (null? ais)
- (network-error 'socket-connect/ai "no addresses to connect to"))
- (let loop ((ais ais))
- (let* ((ai (car ais))
- (addr (addrinfo-address ai))
- (so (socket (addrinfo-family ai) (addrinfo-socktype ai) 0)))
- (if (null? (cdr ais))
- (begin (socket-connect so addr) so)
- (condition-case
- (begin (socket-connect so addr) so)
- (e (exn i/o net timeout)
- (loop (cdr ais)))
- (e (exn i/o net transient)
- (loop (cdr ais))))))))
- ;; (socket-bind s (addrinfo-address (car (address-information "127.0.0.1" 9112 socktype: sock/stream flags: ai/passive))))
- ;; ... is verbose.
- ;; Normal usage is (socket-bind s (inet-address "127.0.0.1" 9112)).
- ;; Using (inet-address #f nnn) will bind to the unspecified address, although that
- ;; may not match the socket type.
- (define (socket-bind so saddr)
- (define _bind (foreign-lambda int "bind" int scheme-pointer int))
- (let ((b (_bind (socket-fileno so) (sockaddr-blob saddr) (sockaddr-len saddr))))
- (if (eq? -1 b)
- (network-error/errno 'socket-bind "cannot bind to socket" so saddr)
- (void))))
- ;; Listening on datagram socket throws an OS error.
- (define (socket-listen so backlog)
- (define _listen (foreign-lambda int "listen" int int))
- (let ((l (_listen (socket-fileno so) backlog)))
- (when (eq? -1 l)
- (network-error/errno 'socket-listen "cannot listen on socket" so))))
- (define (socket-close so)
- (let ((s (socket-fileno so)))
- (when (fx= -1 (_close_socket s))
- (network-error/errno 'socket-close "could not close socket" so))))
- (define (socket-close* so) ;; Close socket, ignoring any error.
- (_close_socket (socket-fileno so))
- (void))
- ;; Returns a socket object representing the accepted connection.
- ;; Does not currently return the socket address of the remote, although it could;
- ;; alternatively you can get it from getpeername.
- (define (socket-accept so)
- (define _accept (foreign-lambda int "accept" int c-pointer c-pointer))
- (let ((s (socket-fileno so))
- (to (socket-accept-timeout)))
- (let restart ()
- (let ((f (select-for-read s)))
- (cond
- ((eq? f -1)
- (network-error/errno 'socket-accept "select failed" so))
- ((eq? f 1)
- (let ((s (_accept s #f #f)))
- (when (eq? -1 s)
- (network-error/errno 'socket-accept "could not accept from listener" so))
- (let ((so (make-socket s (socket-family so) (socket-type so) (socket-protocol so))))
- (unless (_make_socket_nonblocking s)
- (network-error/errno 'socket-accept "unable to set socket to non-blocking" so))
- so)))
- (else
- (block-for-timeout! 'socket-accept to s #:input)
- (restart)))))))
- ;; Returns number of bytes received. If 0, and socket is sock/stream, peer has shut down his side.
- (define (socket-receive! so buf #!optional (start 0) (end #f) (flags 0))
- (let* ((buflen (cond ((string? buf) (string-length buf))
- ((blob? buf) (blob-size buf))
- (else
- (network-error 'socket-receive!
- "receive buffer must be a blob or a string" so))))
- (end (or end buflen)))
- (check-socket so 'socket-receive!)
- (##sys#check-exact start)
- (##sys#check-exact end)
- (##sys#check-exact flags)
- (when (or (fx< start 0)
- (fx> end buflen)
- (fx< end start))
- (network-error 'socket-receive! "receive buffer offsets out of range" start end))
- (%socket-receive! so buf start (fx- end start) flags (socket-receive-timeout))))
- ;; Variant of socket-receive! which does not check so, buf, start, or len and which takes
- ;; read timeout as parameter. Basically for use in socket ports.
- (define (%socket-receive! so buf start len flags timeout)
- (define _recv_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start)
- (int len) (int flags))
- "C_return(recv(s,((char*)buf)+start,len,flags));"))
- (let ((s (%socket-fileno so)))
- (let restart ()
- (let ((n (_recv_offset s buf start len flags)))
- (cond ((eq? -1 n)
- (let ((err errno))
- (cond ((eq? err _ewouldblock)
- (block-for-timeout! 'socket-receive! timeout s #:input)
- (restart))
- (else
- (network-error/errno* 'socket-receive! err "cannot read from socket" so)))))
- (else n))))))
- ;; Receive up to LEN bytes from socket and return as a string.
- ;; TODO: Each socket or perhaps thread should have a dedicated input buffer which is
- ;; equal to the largest LEN ever given here, to avoid excessive allocation.
- ;; TODO: Should LEN default to socket-receive-buffer-size ?
- (define (socket-receive so len #!optional (flags 0))
- (let ((buf (make-string len))) ; checks len exact
- (check-socket so 'socket-receive)
- (##sys#check-exact flags)
- (let ((n (%socket-receive! so buf 0 len flags (socket-receive-timeout))))
- (if (= len n)
- buf
- (substring buf 0 n)))))
- ;; Returns 2 values: number of bytes received, and socket address from which they were
- ;; received.
- ;; NB Cut-and-paste from socket-receive! -- not clear whether we can safely
- ;; use recvfrom with NULL socket address to simulate recv() on all platforms.
- (define (socket-receive-from! so buf #!optional (start 0) (end #f) (flags 0))
- (let* ((buflen (cond ((string? buf) (string-length buf))
- ((blob? buf) (blob-size buf))
- (else
- (network-error 'socket-receive-from!
- "receive buffer must be a blob or a string" so))))
- (end (or end buflen)))
- (check-socket so 'socket-receive-from!)
- (##sys#check-exact start)
- (##sys#check-exact end)
- (##sys#check-exact flags)
- (when (or (fx< start 0)
- (fx> end buflen)
- (fx< end start))
- (network-error 'socket-receive-from! "receive buffer offsets out of range" start end))
- (let ((R (%socket-receive-from! so buf start (fx- end start) flags (socket-receive-timeout))))
- (values (car R) (cdr R)))))
- (define (%socket-receive-from! so buf start len flags timeout)
- (define _recvfrom_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start)
- (int len) (int flags)
- (scheme-pointer addr) ((c-pointer int) addrlen))
- "C_return(recvfrom(s,((char*)buf)+start,len,flags,addr,addrlen));"))
- (let-location ((addrlen int _sockaddr_storage_size))
- (let ((s (%socket-fileno so))
- (addr (make-blob _sockaddr_storage_size)))
- (let restart ()
- (let ((n (_recvfrom_offset s buf start len flags addr (location addrlen))))
- (cond ((eq? -1 n)
- (let ((err errno))
- (cond ((eq? err _ewouldblock)
- (block-for-timeout! 'socket-receive! timeout s #:input)
- (restart))
- (else
- (network-error/errno* 'socket-receive! err "cannot read from socket" so)))))
- (else
- (cons n
- (sa->sockaddr (location addr) addrlen)))))))))
- (define (unix-address path)
- (cond-expand
- (AF_UNIX
- (define _make_unix_sa
- (foreign-lambda* c-pointer ((nonnull-c-string path))
- "struct sockaddr_un *addr; "
- "addr = C_malloc(sizeof *addr);"
- "memset(addr,0,sizeof *addr);"
- "addr->sun_family = AF_UNIX;"
- "strncpy(addr->sun_path, path, sizeof addr->sun_path - 1);"
- "addr->sun_path[sizeof addr->sun_path - 1] = '\\0';"
- "C_return(addr);"))
- (define _free (foreign-lambda void "C_free" c-pointer))
- (let ((sa (_make_unix_sa path)))
- (let ((addr (sa->sockaddr sa (foreign-value "sizeof(struct sockaddr_un)" int))))
- (_free sa)
- addr)))
- (else
- (error 'unix-address "unix sockets are not supported on this platform"))))
- ;; Receive up to LEN bytes from unconnected socket and return 2 values:
- ;; the received string and the socket address from whence it came.
- ;; See TODOs at socket-receive.
- (define (socket-receive-from so len #!optional (flags 0))
- (let ((buf (make-string len))) ; checks len exact
- (check-socket so 'socket-receive-from)
- (##sys#check-exact flags)
- (let ((R (%socket-receive-from! so buf 0 len flags (socket-receive-timeout))))
- (let ((n (car R)))
- (values (if (= len n) buf (substring buf 0 n))
- (cdr R))))))
- (define (socket-receive-ready? so)
- (let ((f (select-for-read (socket-fileno so))))
- (when (eq? -1 f)
- (network-error/errno 'socket-receive-ready? "unable to check socket for input" so))
- (eq? 1 f)))
- (define socket-accept-ready? socket-receive-ready?)
- (define (socket-send so buf #!optional (start 0) (end #f) (flags 0))
- (let* ((buflen (cond ((string? buf) (string-length buf))
- ((blob? buf) (blob-size buf))
- (else
- (network-error 'socket-send
- "send buffer must be a blob or a string" so))))
- (end (or end buflen)))
- (check-socket so 'socket-send)
- (##sys#check-exact start)
- (##sys#check-exact end)
- (##sys#check-exact flags)
- (when (or (fx< start 0)
- (fx> end buflen)
- (fx< end start))
- (network-error 'socket-send "send buffer offsets out of range" start end))
- (%socket-send so buf start (fx- end start) flags (socket-send-timeout))))
- (define (%socket-send so buf start len flags timeout)
- (define _send_offset (foreign-lambda* int ((int s) (scheme-pointer buf) (int start)
- (int len) (int flags))
- "C_return(send(s,((char*)buf)+start,len,flags));"))
- (let ((s (%socket-fileno so)))
- (let retry ((len len) (start start))
- (let ((n (_send_offset s buf start len flags)))
- (cond ((eq? -1 n)
- (let ((err errno))
- (cond ((eq? err _ewouldblock)
- (block-for-timeout! 'socket-send timeout s #:output)
- (retry len start))
- (else
- (network-error/errno* 'socket-send err "cannot send to socket" so)))))
- (else n))))))
- ;; Socket output chunk size for send-all. For compatibility with Unit TCP; maybe not necessary.
- ;; If #f, attempt to send as much as possible. Only question is whether it is safe to exceed
- ;; the socket send buffer size, which may (according to Microsoft pages) cause stalling until
- ;; delayed ACKs come back.
- (define socket-send-size (make-parameter 16384))
- (define socket-send-buffer-size (make-parameter #f))
- ;;(define socket-receive-size (make-parameter 1024)) ;;?
- (define socket-receive-buffer-size (make-parameter 4096))
- (define-foreign-variable +maximum-string-length+ int "C_HEADER_SIZE_MASK") ;; horrible
- (define (%socket-send-all so buf start slen flags timeout chunksz)
- (let ((chunksz (or chunksz +maximum-string-length+)))
- (let loop ((len slen) (start start))
- (let* ((count (fxmin chunksz len))
- (n (%socket-send so buf start count flags timeout)))
- (if (fx< n len)
- (loop (fx- len n) (fx+ start n))
- (void))))))
- (define (socket-send-all so buf #!optional (start 0) (end #f) (flags 0))
- (let* ((buflen (cond ((string? buf) (string-length buf))
- ((blob? buf) (blob-size buf))
- (else
- (network-error 'socket-send-all
- "send buffer must be a blob or a string" so))))
- (end (or end buflen)))
- (check-socket so 'socket-send-all)
- (##sys#check-exact start)
- (##sys#check-exact end)
- (##sys#check-exact flags)
- (when (or (fx< start 0)
- (fx> end buflen)
- (fx< end start))
- (network-error 'socket-send-all "send buffer offsets out of range" start end))
- (%socket-send-all so buf start (fx- end start) flags
- (socket-send-timeout)
- (socket-send-size))))
- ;; Like socket-send, but used for connectionless protocols; sends to non-connected
- ;; address SADDR.
- (define (socket-send-to so buf saddr #!optional (start 0) (end #f) (flags 0))
- (let* ((buflen (cond ((string? buf) (string-length buf))
- ((blob? buf) (blob-size buf))
- (else
- (network-error 'socket-send-to
- "send buffer must be a blob or a string" so))))
- (end (or end buflen)))
- (check-socket so 'socket-send-to)
- (##sys#check-exact start)
- (##sys#check-exact end)
- (##sys#check-exact flags)
- (when (or (fx< start 0)
- (fx> end buflen)
- (fx< end start))
- (network-error 'socket-send-to "send buffer offsets out of range" start end))
- (%socket-send-to so buf saddr start (fx- end start) flags (socket-send-timeout))))
- (define (%socket-send-to so buf saddr start len flags timeout)
- (define _sendto_offset (foreign-lambda* int ((int s) (scheme-pointer buf)
- (int start) (int len) (int flags)
- (scheme-pointer addr) (int addrlen))
- "C_return(sendto(s,((char*)buf)+start,len,flags,addr,addrlen));"))
- (let ((s (%socket-fileno so))
- (addr (sockaddr-blob saddr)) ;; maybe pull this out into caller
- (addrlen (sockaddr-len saddr)))
- (let retry ((len len) (start start))
- (let ((n (_sendto_offset s buf start len flags addr addrlen)))
- (cond ((eq? -1 n)
- (let ((err errno))
- (cond ((eq? err _ewouldblock)
- (block-for-timeout! 'socket-send-to timeout s #:output)
- (retry len start))
- (else
- (network-error/errno* 'socket-send-to err "cannot send to socket" so saddr)))))
- (else n))))))
- ;; Shutdown socket. If socket is not connected, silently ignore the error, because
- ;; the peer may have already initiated shutdown. That behavior should perhaps be configurable.
- (define (socket-shutdown so how) ;; how: shut/rd, shut/wr, shut/rdwr
- (define _shutdown (foreign-lambda int "shutdown" int int))
- (when (eq? -1 (_shutdown (socket-fileno so) how))
- (let ((err errno))
- (unless (eq? err _enotconn)
- (network-error/errno* 'socket-shutdown err "unable to shutdown socket" so how))))
- (void))
- ;; Return #f for unbound socket. On Windows, must test WSAEINVAL.
- ;; On UNIX, testing for port 0 should be sufficient.
- ;; UNIX sockets don't have a name; just return #f.
- (define (socket-name so) ;; a legacy name
- (define _free (foreign-lambda void "C_free" c-pointer))
- (cond #? (AF_UNIX
- ((eq? (socket-family so) AF_UNIX) #f)
- (#f #f))
- (else
- (let-location ((len int))
- (let ((sa (_getsockname (socket-fileno so) (location len))))
- (let ((err errno))
- (cond (sa
- (let ((addr (sa->sockaddr sa len)))
- (_free sa)
- (if (= 0 (sockaddr-port addr))
- #f
- addr)))
- (else
- (if (cond-expand (windows (eq? err _einval))
- (else #f))
- #f
- (network-error/errno 'socket-name "unable to get socket name" so))))))))))
- (define (socket-peer-name so)
- (define _free (foreign-lambda void "C_free" c-pointer))
- (let-location ((len int))
- (let ((sa (_getpeername (socket-fileno so) (location len))))
- (let ((err errno))
- (if sa
- (let ((addr (sa->sockaddr sa len)))
- (_free sa)
- addr)
- (if (eq? err _enotconn)
- #f
- (network-error/errno* 'socket-peer-name err
- "unable to get socket peer name" so)))))))
- (define _getsockname
- (foreign-lambda* c-pointer ((int s) ((c-pointer int) len))
- "struct sockaddr_storage *ss;"
- "ss = (struct sockaddr_storage *)C_malloc(sizeof(*ss));"
- "*len = sizeof(*ss);"
- "if (getsockname(s, (struct sockaddr *)ss, (socklen_t *)len) != 0) C_return(NULL);"
- "C_return(ss);"))
- (define _getpeername
- (foreign-lambda* c-pointer ((int s) ((c-pointer int) len))
- "struct sockaddr_storage *ss;"
- "ss = (struct sockaddr_storage *)C_malloc(sizeof(*ss));"
- "*len = sizeof(*ss);"
- "if (getpeername(s, (struct sockaddr *)ss, (socklen_t *)len) != 0) C_return(NULL);"
- "C_return(ss);"))
- ;;; socket options
- (include "socket-options.scm")
- ;;; ports
- ;; FIXME: port->fileno calls ##sys#tcp-port->fileno and requires the TCP
- ;; core unit to be loaded. Theoretically, we could define this ourselves,
- ;; and avoid this crap with compatible socket ports. However, this would
- ;; require tcp to be loaded first so it does not overwrite our export.
- ;; Also keep in mind it cannot be defined inside a module.
- ;; We unfortunately must maintain compatibility with Unit tcp ports so
- ;; that port->fileno works (relied on by, e.g., sendfile). Thus we
- ;; must have port of type 'socket and vector port data containing the
- ;; fileno as slot 0. So procedures in Unit TCP that take ports will
- ;; accept our ports and possibly crash :( However, we can avoid taking
- ;; TCP ports here by adding unique data to the end of the structure.
- (define-inline (socket-port-data p)
- (or (and (eq? (##sys#slot p 7) 'socket)
- (let ((d (##sys#port-data p)))
- (and (vector? d)
- (= (vector-length d) 7)
- (eq? (##sys#slot d 5) 'socket6)
- d)))
- (type-error 'socket-port-data "argument is not a socket port" p)))
- (define-inline (%socket-port-data-socket data) (##sys#slot data 6))
- (define-inline (%socket-port-data-input-abandoned? data) (##sys#slot data 1))
- (define-inline (%socket-port-data-output-abandoned? data) (##sys#slot data 2))
- (define (socket-i/o-port->socket p)
- (%socket-port-data-socket (socket-port-data p)))
- (define socket-i/o-ports
- (lambda (so)
- (let* ((fd (socket-fileno so))
- (input-buffer-size (socket-receive-buffer-size))
- (buf (make-string input-buffer-size))
- (data (vector fd #f #f buf 0 'socket6 so))
- (buflen 0)
- (bufindex 0)
- (iclosed #f)
- (oclosed #f)
- (outbufsize (socket-send-buffer-size))
- (outbuf (and outbufsize (fx> outbufsize 0)
- (make-string outbufsize)))
- (outbufindex 0)
- (tmr (socket-receive-timeout))
- (tmw (socket-send-timeout))
- (output-chunk-size (socket-send-size))
- (read-input
- (lambda ()
- (let ((n (%socket-receive! so buf 0 input-buffer-size 0 tmr)))
- (set! buflen n)
- (##sys#setislot data 4 n)
- (set! bufindex 0))))
- (in
- (make-input-port
- (lambda ()
- (when (fx>= bufindex buflen)
- (read-input))
- (if (fx>= bufindex buflen)
- #!eof
- (let ((c (##core#inline "C_subchar" buf bufindex)))
- (set! bufindex (fx+ bufindex 1))
- c) ) )
- (lambda ()
- (or (fx< bufindex buflen)
- (socket-receive-ready? so)))
- (lambda ()
- (unless iclosed
- (set! iclosed #t)
- (unless (%socket-port-data-input-abandoned? data) ;; Skip this for dgram?
- (socket-shutdown so shut/rd)) ;; Must not error if peer has shutdown.
- (when oclosed
- (socket-close so))))
- (lambda ()
- (when (fx>= bufindex buflen)
- (read-input))
- (if (fx< bufindex buflen)
- (##core#inline "C_subchar" buf bufindex)
- #!eof))
- (lambda (p n dest start) ; read-string!
- (let loop ((n n) (m 0) (start start))
- (cond ((eq? n 0) m)
- ((fx< bufindex buflen)
- (let* ((rest (fx- buflen bufindex))
- (n2 (if (fx< n rest) n rest)))
- (##core#inline "C_substring_copy" buf dest bufindex (fx+ bufindex n2) start)
- (set! bufindex (fx+ bufindex n2))
- (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )
- (else
- (read-input)
- (if (eq? buflen 0)
- m
- (loop n m start) ) ) ) ) )
- #-scan-buffer-line-returns-3-vals
- (lambda (p limit) ; read-line
- (let loop ((str #f)
- (limit (or limit (##sys#fudge 21))))
- (cond ((fx< bufindex buflen)
- (##sys#scan-buffer-line
- buf
- (fxmin buflen limit)
- bufindex
- (lambda (pos2 next)
- (let* ((len (fx- pos2 bufindex))
- (dest (##sys#make-string len)))
- (##core#inline "C_substring_copy" buf dest bufindex pos2 0)
- (set! bufindex next)
- (cond ((eq? pos2 limit) ; no line-terminator, hit limit
- (if str (##sys#string-append str dest) dest))
- ((eq? pos2 next) ; no line-terminator, hit buflen
- (read-input)
- (if (fx>= bufindex buflen)
- (or str "")
- (loop (if str (##sys#string-append str dest) dest)
- (fx- limit len)) ) )
- (else
- (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
- (if str (##sys#string-append str dest) dest)) ) ) ) ) )
- (else
- (read-input)
- (if (fx< bufindex buflen)
- (loop str limit)
- #!eof) ) ) ) )
- #+scan-buffer-line-returns-3-vals
- (lambda (p limit) ; read-line
- (when (fx>= bufindex buflen)
- (read-input))
- (if (fx>= bufindex buflen)
- #!eof
- (let ((limit (or limit (fx- (##sys#fudge 21) bufindex))))
- (receive (next line full-line?)
- (##sys#scan-buffer-line
- buf
- (fxmin buflen (fx+ bufindex limit))
- bufindex
- (lambda (pos)
- (let ((nbytes (fx- pos bufindex)))
- (cond ((fx>= nbytes limit)
- (values #f pos #f))
- (else (read-input)
- (set! limit (fx- limit nbytes))
- (if (fx< bufindex buflen)
- (values buf bufindex
- (fxmin buflen
- (fx+ bufindex limit)))
- (values #f bufindex #f))))) ) )
- ;; Update row & column position
- (if full-line?
- (begin
- (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
- (##sys#setislot p 5 0))
- (##sys#setislot p 5 (fx+ (##sys#slot p 5)
- (##sys#size line))))
- (set! bufindex next)
- line) )) )
- ;; (lambda (p) ; read-buffered
- ;; (if (fx>= bufindex buflen)
- ;; ""
- ;; (let ((str (##sys#substring buf bufpos buflen)))
- ;; (set! bufpos buflen)
- ;; str)))
- ) )
- (output
- (lambda (str off len)
- (%socket-send-all so str off len 0 tmw output-chunk-size)))
- (out
- (make-output-port
- (if outbuf
- (lambda (s)
- ;; This sends the whole existing buffer + string as soon as it exceeds
- ;; the buffer size. That is useful to buffer small amounts of data
- ;; (bufsz < chunksz). We could also send only in bufsz increments.
- ;; That is useful when bufsz > chunksz and bufsz is a multiple (I think).
- ;; Also may make sense when sending UDP to guarantee packets are always
- ;; fixed size until an explicit flush. Of course if you have that requirement
- ;; I suspect you will need to construct packets/strings yourself to ensure
- ;; the last one is padded. (?)
- ;; Modified from Unit TCP. No longer does string-appends to build buffer;
- ;; instead writes into static buffer until exhausted, with a single
- ;; string-append at end if exceeded buffer space.
- (let ((olen (fx+ (##sys#size s) outbufindex)))
- (cond ((fx= (##sys#size s) 0))
- ((fx< olen outbufsize)
- (##core#inline "C_substring_copy" s outbuf 0 (##sys#size s) outbufindex)
- (set! outbufindex olen))
- ((fx= olen outbufsize)
- (##core#inline "C_substring_copy" s outbuf 0 (##sys#size s) outbufindex)
- (output outbuf 0 outbufsize)
- (set! outbufindex 0))
- (else
- ;; Optimizations: If empty buffer, no string-append required.
- ;; Future opts: Can probably do smaller string appends of one
- ;; chunk for chunk alignment, then write rest out. Until then,
- ;; you can flush the buffer before a big write.
- (let* ((slop (fxmod olen outbufsize))
- (end (fx- olen slop)))
- (print `(slop ,slop end ,end))
- (let ((s (if (fx= outbufindex 0)
- s
- (##sys#string-append
- (substring outbuf 0 outbufindex) s))))
- (print `(s ,s))
- (output s 0 end)
- (when (fx> slop 0)
- (print `(slopping))
- (##core#inline "C_substring_copy" s outbuf end olen 0))
- (set! outbufindex slop))))))
- (void))
- (lambda (s)
- (when (fx> (##sys#size s) 0)
- (output s 0 (##sys#size s))) ) )
- (lambda ()
- (unless oclosed
- (set! oclosed #t)
- (when (and outbuf (fx> outbufindex 0))
- (output outbuf 0 outbufindex)
- (set! outbufindex 0))
- ;; Note some odd closesocket() behavior with discarded output at:
- ;; http://msdn.microsoft.com/en-us/library/ms738547 (v=vs.85).aspx
- (unless (%socket-port-data-output-abandoned? data)
- (socket-shutdown so shut/wr))
- (when iclosed
- (socket-close so))))
- (and outbuf
- (lambda ()
- (when (fx> outbufindex 0)
- (output outbuf 0 outbufindex)
- (set! outbufindex 0) ) ) ) ) ) )
- (##sys#setslot in 3 "(socket)")
- (##sys#setslot out 3 "(socket)")
- (##sys#setslot in 7 'socket) ;; compatibility with core socket ports
- (##sys#setslot out 7 'socket)
- (##sys#set-port-data! in data)
- (##sys#set-port-data! out data)
- (values in out) ) ) )
- (define (socket-abandon-port p)
- (let ((d (socket-port-data p)))
- (if (input-port? p)
- (##sys#setislot d 1 #t)
- (##sys#setislot d 2 #t)))) ;; Note: polarity is reversed from unit tcp
- ;;; network startup
- (define socket-startup
- (foreign-lambda* bool () "
- #ifdef _WIN32
- C_return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);
- #else
- signal(SIGPIPE, SIG_IGN);
- C_return(1);
- #endif
- "))
- ;; We require unit tcp above so this should already be done.
- ;; (unless (socket-startup) ;; hopefully, this is safe to run multiple times
- ;; (network-error 'socket-startup "cannot initialize socket code"))
- ;;; Notes / TODOs
- #|
- UNIX sockets not supported because they do not exist on Windows (though we could test for this)
- socket-accept should perhaps return connected peer address
- not all errors close the socket (probably should) -- e.g., recv failure, send failure;
- however, on a timeout, ports require that the socket stay open
- implement socket-receive
- output line buffering not implemented
- socket ports work with datagrams
- Socket type (slot 7) is deliberately set to "socket6" instead of "socket" to prevent
- port->fileno from accessing port data (which is in a different format). This is hardcoded
- in the core library.
- --However this prevents the sendfile egg from using the fastpath! This is a critical bug.
- |#