;;; -*- Mode: Scheme -*-

;;;; BSD Socket API

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; 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 names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.

(begin-c-stub "bsd-socket")

(c-system-include "sys/types.h")

(c-system-include "netinet/in.h")
(c-system-include "sys/socket.h")
(c-system-include "sys/un.h")

(c-system-include "errno.h")
(c-system-include "string.h")
(c-system-include "unistd.h")

(define-c-constant-enumeration socket-domain "int"
  (unspecific   "AF_UNSPEC")
  (unix         "AF_UNIX")
  (internet     "AF_INET")
  (internet6    "AF_INET6")
  )

(define-c-constant-enumeration socket-type "int"
  (stream                       "SOCK_STREAM")
  (datagram                     "SOCK_DGRAM")
  (raw                          "SOCK_RAW")
  (reliably-delivered-message   "SOCK_RDM")
  (sequenced-packet-stream      "SOCK_SEQPACKET")
  )

(define-c-constant-enumeration socket-shutdown-direction "int"
  (read         "SHUT_RD")
  (write        "SHUT_WR")
  (read&write   "SHUT_RDWR")
  )

;++ Improve this.

(define-c-integral-conversion c-socket-protocol "int")

(define default-socket-protocol 0)

;;;; Socket Addresses

;;; All of this socket address crap should be in a separate module.

(c-declare
  "#define DECLARE_SOCKADDR(NAME, LENGTH)                      \\"
  "  struct sockaddr_storage NAME ## _storage = { 0 };         \\"
  "  struct sockaddr *NAME                                     \\"
  "    = ((struct sockaddr *) (& (NAME ## _storage)));         \\"
  "  socklen_t LENGTH                                          \\"
  "    = ((socklen_t) (sizeof (NAME ## _storage)))              ")

(define-c-record internet-socket-address "struct sockaddr_in"
    (make-internet-socket-address port address)
  (c->record "sockaddr"
    (port (c-unsigned "in_port_t" "ntohs (sockaddr -> sin_port)"))
    (address
     (c-copied-byte-vector "& ((sockaddr -> sin_addr) . s_addr)" "0" "4")))
  (record->c "sockaddr"
      ((port (c-unsigned "in_port_t"))
       (address (c-immutable-byte-vector "address" "address_length")))
    "(sockaddr -> sin_family) = AF_INET;                "
    "(sockaddr -> sin_port) = (htons (port));           "
    "memcpy ((& ((sockaddr -> sin_addr) . s_addr)),     "
    "        address,                                   "
    "        address_length);                           "))

(define-c-record internet6-socket-address "struct sockaddr_in6"
    (make-internet6-socket-address port flow-info address scope-id)
  (c->record "sockaddr"
    (port (c-unsigned "in_port_t" "sockaddr -> sin6_port"))
    (flow-info (c-unsigned "uint32_t"  "sockaddr -> sin6_flowinfo"))
    (address
     (c-copied-byte-vector "& ((sockaddr -> sin6_addr) . s6_addr)" "0" "16"))
    (scope-id
     (c-unsigned "uint32_t" "sockaddr -> sin6_scope_id")))
  (record->c "sockaddr"
      ((port (c-unsigned "in_port_t"))
       (flow-info (c-unsigned "uint32_t"))
       (address (c-immutable-byte-vector "address" "address_length"))
       (scope-id (c-unsigned "uint32_t")))
    "(sockaddr -> sin6_family) = AF_INET6;              "
    "(sockaddr -> sin6_port) = port;                    "
    "(sockaddr -> sin6_flowinfo) = flow_info;           "
    "memcpy ((& ((sockaddr -> sin6_addr) . s6_addr)),   "
    "        address,                                   "
    "        address_length);                           "
    "(sockaddr -> sin6_scope_id) = scope_id;            "))

;;;;; Unix Socket Addresses

(c-declare
  "static size_t                                                "
  "sockaddr_un_path_length (const struct sockaddr_un *sockaddr) "
  "{                                                            "
  "  size_t max = (sizeof (sockaddr -> sun_path));              "
  "  size_t length;                                             "
  "  const char *scan;                                          "
  "  for (length = 0, scan = (sockaddr -> sun_path);            "
  "       ((length < max) && ((*scan) != 0));                   "
  "       length += 1, scan += 1);                              "
  "  return (length);                                           "
  "}                                                            ")

(define-c-record unix-socket-address "struct sockaddr_un"
    (make-unix-socket-address pathname)
  (c->record "address"
    (pathname
     (c-copied-byte-vector "address -> sun_path"
                           "0"
                           "1 + (sockaddr_un_path_length (address))")))
  (record->c "address"
      ((pathname (c-immutable-byte-vector "pathname" "pathname_length")))
    "(address -> sun_family) = AF_UNIX;         "
    "memcpy ((& (address -> sun_path)),         "
    "        pathname,                          "
    "        pathname_length);                  "))

;;;;; Socket Address Conversions

(define-record-type unknown-socket-address
    (make-unknown-socket-address byte-vector)
    unknown-socket-address?
  (byte-vector unknown-socket-address.byte-vector))

(define (socket-address->byte-vector socket-address)
  (cond ((internet-socket-address? socket-address)
         (internet-socket-address->byte-vector socket-address))
        ((internet6-socket-address? socket-address)
         (internet6-socket-address->byte-vector socket-address))
        ((unix-socket-address? socket-address)
         (unix-socket-address->byte-vector socket-address))
        ((unknown-socket-address? socket-address)
         (unknown-socket-address.byte-vector socket-address))
        (else
         (error "Invalid socket address:" socket-address))))

(define-c (internet-socket-address->byte-vector
           (socket-address c-internet-socket-address))
  (c-copied-byte-vector "&socket_address" "0" "sizeof (socket_address)"))

(define-c (internet6-socket-address->byte-vector
           (socket-address c-internet6-socket-address))
  (c-copied-byte-vector "&socket_address" "0" "sizeof (socket_address)"))

(define-c (unix-socket-address->byte-vector
           (socket-address c-unix-socket-address))
  (c-copied-byte-vector "&socket_address" "0" "sizeof (socket_address)"))

(define (byte-vector->socket-address byte-vector)
  (or (maybe-byte-vector->socket-address byte-vector)
      (make-unknown-socket-address byte-vector)))

(define-c (maybe-byte-vector->socket-address
           (byte-vector
            (c-immutable-byte-vector "address_bytes" "address_length")))
  (c-declare "DECLARE_SOCKADDR (address, storage_length);       "
             "sa_family_t family;                               ")
  (c-begin
    "memcpy (address, address_bytes,                            "
    "        ((address_length < storage_length)                 "
    "         ? address_length                                  "
    "         : storage_length));                               "
    "family = (address -> sa_family);                           "
    (c-cond ("family == AF_INET"
             (c-if "address_length >= (sizeof (struct sockaddr_in))"
               (c-internet-socket-address "(struct sockaddr_in *) address")
               (c-false)))
            ("family == AF_INET6"
             (c-if "address_length >= (sizeof (struct sockaddr_in6))"
               (c-internet6-socket-address "(struct sockaddr_in6 *) address")
               (c-false)))
            ("family == AF_UNIX"
             (c-if "address_length >= (sizeof (struct sockaddr_un))"
               (c-unix-socket-address "(struct sockaddr_un *) address")
               (c-false)))
            (c-else
             (c-false)))))

;;;; Creating Sockets

(define (create-socket domain type protocol)
  (open-file-descriptor
   (lambda (alien)
     (%create-socket domain type protocol alien))))

(define-unix-uint-syscall*
    (%create-socket (domain     c-socket-domain)
                    (type       c-socket-type)
                    (protocol   c-socket-protocol)
                    (fd-pointer (c-alien-pointer "int")))
  (c-declare)
  (c-begin)
  (=> "int" "socket_fd")
  ("socket" "domain" "type" "protocol")
  (c-begin
    "(*fd_pointer) = socket_fd;"
    (c-unspecific)))

(define (create-socket-pair domain type protocol)
  (with-file-descriptor-aliens ((socket-a alien-a) (socket-b alien-b))
      (%create-socket-pair domain type protocol alien-a alien-b)
    (values socket-a socket-b)))

(define-unix-void-syscall
    (%create-socket-pair (domain        c-socket-domain)
                         (type          c-socket-type)
                         (protocol      c-socket-protocol)
                         (fd-pointer-a  (c-alien-pointer "int"))
                         (fd-pointer-b  (c-alien-pointer "int")))
  (c-declare "int socket_fds [2];")
  ("socketpair" "domain" "type" "protocol" "socket_fds")
  (c-begin
    "(*fd_pointer_a) = (socket_fds [0]);"
    "(*fd_pointer_b) = (socket_fds [1]);"
    (c-unspecific)))

;;;; Miscellaneous Socket Operations

(define (shutdown-socket socket-fd direction)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%shutdown-socket number direction))))

(define-unix-void-syscall
    (%shutdown-socket (socket-fd (c-integral "int"))
                      (direction c-socket-shutdown-direction))
  "shutdown")

(define (bind-socket socket-fd address)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%bind-socket number (socket-address->byte-vector address)))))

(define-unix-void-syscall
    (%bind-socket
     (socket-fd (c-integral "int"))
     (address   (c-immutable-byte-vector "address_bytes" "address_length")))
  (c-declare "struct sockaddr *address;")
  (c-begin "address = ((struct sockaddr *) address_bytes);")
  ("bind" "socket_fd" "address" "address_length"))

(define-c (max-listen-backlog)
  (c-integral "int" "SOMAXCONN"))

(define (listen-socket socket-fd backlog)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%listen-socket number backlog))))

(define-unix-void-syscall
    (%listen-socket (socket-fd  (c-integral "int"))
                    (backlog    (c-integral "int")))
  "listen")

(define (socket.address socket-fd)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (byte-vector->socket-address (%socket.address number)))))

(define-unix-void-syscall (%socket.address (socket-fd (c-integral "int")))
  (c-declare "DECLARE_SOCKADDR (address, address_length);")
  ("getsockname" "socket_fd" "address" "&address_length")
  (c-copied-byte-vector "address" "0" "address_length"))

(define (socket.peer-address socket-fd)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (byte-vector->socket-address (%socket.peer-address number)))))

(define-unix-void-syscall
    (%socket.peer-address (socket-fd (c-integral "int")))
  (c-declare "DECLARE_SOCKADDR (address, address_length);")
  ("getpeername" "socket_fd" "address" "&address_length")
  (c-copied-byte-vector "address" "0" "address_length"))

;;;; Socket Options

(define-syntax define-socket-option-reader
  (syntax-rules (C-DECLARE)

    ;; Either a parameter or a declaration must define option_name.
    ((DEFINE-SOCKET-OPTION-READER name level c-type (parameter ...)
       (C-DECLARE declaration ...)
       expression)
     (DEFINE-UNIX-VOID-SYSCALL
         (name (SOCKET-FD (C-INTEGRAL "int")) parameter ...)
       (C-DECLARE c-type " option_value;        "
                  "socklen_t option_length;     "
                  declaration ...)
       (C-BEGIN "option_length = (sizeof (option_value));")
       ("getsockopt" "socket_fd" level "option_name"
                     "(void *) (&option_value)"
                     "&option_length")
       expression))

    ((DEFINE-SOCKET-OPTION-READER name level c-type (parameter ...) expression)
     (DEFINE-SOCKET-OPTION-READER name level c-type (parameter ...)
       (C-DECLARE)
       expression))))

(define-syntax define-socket-option-writer
  (syntax-rules ()
    ;; Either a parameter or the prologue must define option_name and
    ;; option_value_ptr.
    ((DEFINE-SOCKET-OPTION-WRITER name level (parameter ...)
       prologue
       ...)
     (DEFINE-UNIX-VOID-SYSCALL
         (name (SOCKET-FD (C-INTEGRAL "int")) parameter ...)
       prologue
       ...
       ("setsockopt" "socket_fd" level "option_name"
                     "(void *) option_value_ptr"
                     "(socklen_t) (sizeof (*option_value_ptr))")))))

(define-c-constant-enumeration boolean-socket-option-name "int"
  (accepting-connections?       "SO_ACCEPTCON")         ;get only
  (broadcast?                   "SO_BROADCAST")
  (debug?                       "SO_DEBUG")
  (dont-route?                  "SO_DONTROUTE")
  (keep-alive?                  "SO_KEEPALIVE")
  (out-of-band-inline?          "SO_OOBINLINE")
  (reuse-address?               "SO_REUSEADDR")
  )

(define-c-constant-enumeration integral-socket-option-name "int"
  (receive-buffer-size  "SO_RCVBUF")
  (receive-low-water    "SO_RCVLOWAT")
  (send-buffer-size     "SO_SNDBUF")
  (send-low-water       "SO_SNDLOWAT")
  )

(define-c-constant-enumeration timeout-socket-option-name "int"
  (receive-timeout      "SO_RCVTIMEO")
  (send-timeout         "SO_SNDTIMEO")
  )

(define (socket.accepting-connections? socket-fd)
  (boolean-socket-option socket-fd
                         (boolean-socket-option-name ACCEPTING-CONNECTIONS?)))

(define (socket.broadcast? socket-fd)
  (boolean-socket-option socket-fd (boolean-socket-option-name BROADCAST?)))

(define (socket.debug? socket-fd)
  (boolean-socket-option socket-fd (boolean-socket-option-name DEBUG?)))

(define (socket.dont-route? socket-fd)
  (boolean-socket-option socket-fd (boolean-socket-option-name DONT-ROUTE?)))

(define (socket.keep-alive? socket-fd)
  (boolean-socket-option socket-fd (boolean-socket-option-name KEEP-ALIVE?)))

(define (socket.out-of-band-inline? socket-fd)
  (boolean-socket-option socket-fd
                         (boolean-socket-option-name OUT-OF-BAND-INLINE?)))

(define (socket.reuse-address? socket-fd)
  (boolean-socket-option socket-fd
                         (boolean-socket-option-name REUSE-ADDRESS?)))

(define (boolean-socket-option socket-fd option-name)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%boolean-socket-option number option-name))))

(define-socket-option-reader %boolean-socket-option "SOL_SOCKET" "int"
    ((option-name c-boolean-socket-option-name))
  (c-boolean "option_value"))

(define (socket.receive-buffer-size socket-fd)
  (integral-socket-option socket-fd
                          (integral-socket-option-name SEND-BUFFER-SIZE)))

(define (socket.receive-low-water socket-fd)
  (integral-socket-option socket-fd
                          (integral-socket-option-name RECEIVE-LOW-WATER)))

(define (socket.send-buffer-size socket-fd)
  (integral-socket-option socket-fd
                          (integral-socket-option-name SEND-BUFFER-SIZE)))

(define (socket.send-low-water socket-fd)
  (integral-socket-option socket-fd
                          (integral-socket-option-name SEND-LOW-WATER)))

(define (integral-socket-option socket-fd option-name)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%integral-socket-option number option-name))))

(define-socket-option-reader %integral-socket-option "SOL_SOCKET" "int"
    ((option-name c-integral-socket-option-name))
  (c-integral "int" "option_value"))

(define (socket.receive-timeout socket-fd)
  (timeout-socket-option socket-fd
                         (timeout-socket-option-name RECEIVE-TIMEOUT)))

(define (socket.send-timeout socket-fd)
  (timeout-socket-option socket-fd (timeout-socket-option-name SEND-TIMEOUT)))

(define (timeout-socket-option socket-fd option)
  (let ((seconds.useconds
         (call-with-file-descriptor-number socket-fd
           (lambda (number)
             (%timeout-socket-option number option)))))
    (values (car seconds.useconds)
            (cdr seconds.useconds))))

(define-socket-option-reader %timeout-socket-option "SOL_SOCKET"
    "struct timeval"
    ((option-name c-timeout-socket-option-name))
  (c-cons (c-integral "time_t"      "option_value . tv_sec")
          (c-integral "suseconds_t" "option_value . tv_usec")))

(define (socket.type socket-fd)
  (call-with-file-descriptor-number socket-fd %socket.type))

(define-socket-option-reader %socket.type "SOL_SOCKET " "int" ()
  (c-declare "int option_name = SO_TYPE;")
  (c-socket-type "option_value"))

(define (socket.error socket-fd)
  (call-with-file-descriptor-number socket-fd %socket.error))

(define-socket-option-reader %socket.error "SOL_SOCKET" "int" ()
  (c-declare "int option_name = SO_ERROR;")
  ;++ This is wrong -- it should return a Unix error code enumerand.
  (c-integral "int" "option_value"))

(define (socket.linger socket-fd)
  (call-with-file-descriptor-number socket-fd %socket.linger))

(define-socket-option-reader %socket.linger "SOL_SOCKET" "struct linger" ()
  (c-declare "int option_name = SO_LINGER;")
  (c-if "option_value . l_onoff"
    (c-integral "int" "option_value . l_linger")
    (c-false)))

(define (set-socket.broadcast?! socket-fd flag)
  (set-boolean-socket-option! socket-fd
                              (boolean-socket-option-name BROADCAST?)
                              flag))

(define (set-socket.debug?! socket-fd flag)
  (set-boolean-socket-option! socket-fd
                              (boolean-socket-option-name DEBUG?)
                              flag))

(define (set-socket.dont-route?! socket-fd flag)
  (set-boolean-socket-option! socket-fd
                              (boolean-socket-option-name DONT-ROUTE?)
                              flag))

(define (set-socket.keep-alive?! socket-fd flag)
  (set-boolean-socket-option! socket-fd
                              (boolean-socket-option-name KEEP-ALIVE?)
                              flag))

(define (set-socket.out-of-band-inline?! socket-fd flag)
  (set-boolean-socket-option! socket-fd
                              (boolean-socket-option-name OUT-OF-BAND-INLINE?)
                              flag))

(define (set-socket.reuse-address?! socket-fd flag)
  (set-boolean-socket-option! socket-fd
                              (boolean-socket-option-name REUSE-ADDRESS?)
                              flag))

(define (set-boolean-socket-option! socket-fd option-name option-value)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%set-boolean-socket-option! number option-name option-value))))

(define-socket-option-writer %set-boolean-socket-option! "SOL_SOCKET"
    ((option-name       c-boolean-socket-option-name)
     (option-value      c-boolean))
  (c-declare "int *option_value_ptr;")
  (c-begin "option_value_ptr = (&option_value);"))

(define (set-socket.receive-buffer-size! socket-fd value)
  (set-integral-socket-option!
   socket-fd
   (integral-socket-option-name RECEIVE-BUFFER-SIZE)
   value))

(define (set-socket.receive-low-water! socket-fd value)
  (set-integral-socket-option! socket-fd
                               (integral-socket-option-name RECEIVE-LOW-WATER)
                               value))

(define (set-socket.send-buffer-size! socket-fd value)
  (set-integral-socket-option! socket-fd
                               (integral-socket-option-name SEND-BUFFER-SIZE)
                               value))

(define (set-socket.send-low-water! socket-fd value)
  (set-integral-socket-option! socket-fd
                               (integral-socket-option-name SEND-BUFFER-SIZE)
                               value))

(define (set-integral-socket-option! socket-fd option-name option-value)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%set-integral-socket-option! number option-name option-value))))

(define-socket-option-writer %set-integral-socket-option! "SOL_SOCKET"
    ((option-name       c-integral-socket-option-name)
     (option-value      (c-integral "int")))
  (c-declare "int *option_value_ptr;")
  (c-begin "option_value_ptr = (&option_value);"))

(define (set-socket.receive-timeout! socket-fd seconds microseconds)
  (set-timeout-socket-option! socket-fd
                              (timeout-socket-option-name RECEIVE-TIMEOUT)
                              seconds
                              microseconds))

(define (set-socket.send-timeout! socket-fd seconds microseconds)
  (set-timeout-socket-option! socket-fd
                              (timeout-socket-option-name SEND-TIMEOUT)
                              seconds
                              microseconds))

(define (set-timeout-socket-option! socket-fd option-name seconds microseconds)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%set-timeout-socket-option! number option-name seconds microseconds))))

(define-socket-option-writer %set-timeout-socket-option! "SOL_SOCKET"
    ((option-name       c-timeout-socket-option-name)
     ;++ This should use some C-UNIX-MICROSECOND-TIME conversion.
     (seconds           (c-integral "time_t"))
     (microseconds      (c-integral "suseconds_t")))
  (c-declare "struct timeval option_value = { 0 };                      "
             "struct timeval *option_value_ptr = (&option_value);       ")
  (c-begin "(option_value . tv_sec) = seconds;                          "
           "(option_value . tv_usec) = microseconds;                    "))

(define (set-socket.linger! socket-fd linger)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (if linger
          (enable-socket-linger! number linger)
          (disable-socket-linger! number)))))

(define-socket-option-writer enable-socket-linger! "SOL_SOCKET"
    ((linger-time (c-integral "int")))
  (c-declare "int option_name = SO_LINGER;              "
             "struct linger option_value = { 0 };       "
             "struct linger *option_value_ptr           "
             "  = (&option_value);                      ")
  (c-begin "(option_value . l_onoff) = 1;               "
           "(option_value . l_linger) = linger_time;    "))

(define-socket-option-writer disable-socket-linger! "SOL_SOCKET"
    ()
  (c-declare "int option_name = SO_LINGER;              "
             "struct linger option_value = { 0 };       "
             "struct linger *option_value_ptr           "
             "  = (&option_value);                      "))

;;;; Connecting, and Accepting Connections

(define (maybe-connect-socket socket-fd address)
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%maybe-connect-socket number (socket-address->byte-vector address)))))

(define-unix-syscall
    (%maybe-connect-socket
     (socket-fd (c-integral "int"))
     (address (c-immutable-byte-vector "address_bytes" "address_length")))
  (c-declare "struct sockaddr *address; "
             "int status;               ")
  (c-begin
    "address = ((struct sockaddr *) address_bytes);             "
    "connect_loop:                                              "
    "  status = (connect (socket_fd, address, address_length)); "
    (c-cond ("status >= 0"
             (c-true))
            ((c-or "errno == EWOULDBLOCK"
                   "errno == EAGAIN"
                   "errno == EINPROGRESS")
             (c-false))
            (c-else
             (c-unix-syscall-failure "connect" "errno" "goto connect_loop")))))

(define (maybe-accept-connection listening-socket-fd)
  (receive (accepted-socket-fd address)
           (%maybe-accept-connection listening-socket-fd)
    (values accepted-socket-fd
            (and address (byte-vector->socket-address address)))))

(define (%maybe-accept-connection listening-socket-fd)
  (let* ((address #f)
         (accepted-socket-fd
          (open-file-descriptor
           (lambda (alien)
             (set! address
                   (call-with-file-descriptor-number listening-socket-fd
                     (lambda (number)
                       (%%maybe-accept-connection number alien))))))))
    (values accepted-socket-fd address)))

(define-unix-syscall
    (%%maybe-accept-connection (listening-socket-fd (c-integral "int"))
                               (accepted-socket-fd-pointer
                                (c-alien-pointer "int")))
  (c-declare "int accepted_socket_fd;                                   "
             "DECLARE_SOCKADDR (address, address_length);               ")
  (c-begin
    "accept_loop:                                                       "
    "  accepted_socket_fd                                               "
    "    = (accept (listening_socket_fd, address, (&address_length)));  "
    (c-cond ("accepted_socket_fd >= 0"
             "(*accepted_socket_fd_pointer) = accepted_socket_fd;       "
             (c-copied-byte-vector "address" "0" "address_length"))
            ((c-and "errno != EWOULDBLOCK" "errno != EAGAIN")
             (c-unix-syscall-failure "accept" "errno" "goto accept_loop"))
            (c-else
             (c-false)))))

;;;; Sending and Receiving

(define-syntax define-unix-send/receive
  (syntax-rules ()

    ;; Make the declarations and initializations optional.
    ((DEFINE-UNIX-SEND/RECEIVE name (internal-name (variable parameter) ...)
         (socket-fd-variable message-variable start-variable end-variable)
       syscall arguments)
     (DEFINE-UNIX-SEND/RECEIVE name (internal-name (variable parameter) ...)
         (socket-fd-variable message-variable start-variable end-variable)
       (C-DECLARE)
       (C-BEGIN)
       syscall arguments))

    ((DEFINE-UNIX-SEND/RECEIVE name (internal-name (variable parameter) ...)
         (socket-fd-variable message-variable start-variable end-variable)
       (C-BEGIN initialization ...)
       syscall arguments)
     (DEFINE-UNIX-SEND/RECEIVE name (internal-name (variable parameter) ...)
         (socket-fd-variable message-variable start-variable end-variable)
       (C-DECLARE)
       (C-BEGIN initialization ...)
       syscall arguments))

    ((DEFINE-UNIX-SEND/RECEIVE name (internal-name (variable parameter) ...)
         (socket-fd-variable message-variable start-variable end-variable)
       (C-DECLARE declaration ...)
       syscall arguments)
     (DEFINE-UNIX-SEND/RECEIVE name (internal-name (variable parameter) ...)
         (socket-fd-variable message-variable start-variable end-variable)
       (C-DECLARE declaration ...)
       (C-BEGIN)
       syscall arguments))

    ((DEFINE-UNIX-SEND/RECEIVE name (internal-name (variable parameter) ...)
         (socket-fd-variable message-variable start-variable end-variable)
       (C-DECLARE declaration ...)
       (C-BEGIN initialization ...)
       syscall arguments)
     (BEGIN
       (DEFINE (name variable ...)
         (IF (NOT (AND (BYTE-VECTOR? message-variable)
                       (INTEGER? start-variable)
                       (INTEGER? end-variable)
                       (<= 0
                           start-variable
                           end-variable
                           (BYTE-VECTOR-LENGTH message-variable))))
             (ERROR "Invalid message:"
                    message-variable start-variable end-variable))
         (CALL-WITH-FILE-DESCRIPTOR-NUMBER socket-fd-variable
           (LAMBDA (socket-fd-variable)
             (internal-name variable ...))))
       (DEFINE-UNIX-SYSCALL (internal-name (variable parameter) ...)
         (C-DECLARE "size_t bytes;" declaration ...)
         (C-BEGIN
           initialization ...
           "syscall_loop:                               "
           "  bytes = (" syscall "(" arguments "));     "
           (C-COND ("bytes >= 0"
                    (C-INTEGRAL "size_t" "bytes"))
                   ((C-AND "errno != EWOULDBLOCK" "errno != EAGAIN")
                    (C-UNIX-SYSCALL-FAILURE syscall
                                            "errno"
                                            "goto syscall_loop"))
                   (C-ELSE
                    (C-FALSE)))))))))

;++ This should implement sendmsg(2) and recvmsg(2) as well.

(define-unix-send/receive socket-send
    (%socket-send
     (socket-fd (c-integral "int"))
     (message   (c-immutable-byte-vector "buffer" "buffer_size"))
     (start     (c-unsigned "size_t"))
     (end       (c-unsigned "size_t")))
    (socket-fd message start end)
  (c-begin "(void) buffer_size;")
  "send" "socket_fd, (buffer + start), (end - start), 0")

(define (socket-send-to socket-fd address message start end)
  (%socket-send-to socket-fd
                   (socket-address->byte-vector address)
                   message
                   start
                   end))

(define-unix-send/receive %socket-send-to
    (%%socket-send-to
     (socket-fd (c-integral "int"))
     (address   (c-immutable-byte-vector "address_bytes" "address_length"))
     (message   (c-immutable-byte-vector "buffer" "buffer_size"))
     (start     (c-unsigned "size_t"))
     (end       (c-unsigned "size_t")))
    (socket-fd message start end)
  (c-declare "struct sockaddr *address;")
  (c-begin
    "(void) buffer_size;        /* Unused */            "
    "address = ((struct sockaddr *) address_bytes);     ")
  "sendto"
  "socket_fd, (buffer + start), (end - start), 0, address, address_length")

;++ recv(2) and recvfrom(2) take flags.

(define-unix-send/receive socket-receive
    (%socket-receive
     (socket-fd (c-integral "int"))
     (message   (c-shared-byte-vector "buffer" "buffer_size"))
     (start     (c-unsigned "size_t"))
     (end       (c-unsigned "size_t")))
    (socket-fd message start end)
  (c-begin "(void) buffer_size;")
  "recv" "socket_fd, (buffer + start), (end - start), 0")

(define (socket-receive-from socket-fd message start end)
  (receive (bytes address) (%socket-receive-from socket-fd message start end)
    (values bytes (and address (byte-vector->socket-address address)))))

(define (%socket-receive-from socket-fd message start end)
  (if (not (and (byte-vector? message)
                (integer? start)
                (integer? end)
                (<= 0 start end (byte-vector-length message))))
      (error "Invalid message:" message start end))
  (call-with-file-descriptor-number socket-fd
    (lambda (number)
      (%%socket-receive-from number message start end))))

(define-unix-syscall
    (%%socket-receive-from
     (socket-fd (c-integral "int"))
     (message   (c-shared-byte-vector "buffer" "buffer_size"))
     (start     (c-unsigned "size_t"))
     (end       (c-unsigned "size_t")))
  (c-declare "size_t bytes;                                             "
             "DECLARE_SOCKADDR (address, address_length);               ")
  (c-begin
    "(void) buffer_size;                                                "
    "recvfrom_loop:                                                     "
    "  bytes = (recvfrom (socket_fd, (buffer + start), (end - start),   "
    "                     0, address, (&address_length)));              "
    (c-cond ("bytes >= 0"
             (c-cons (c-integral "size_t" "bytes")
                     (c-copied-byte-vector "address" "0" "address_length")))
            ((c-and "errno != EWOULDBLOCK" "errno != EAGAIN")
             (c-unix-syscall-failure "recvfrom" "errno" "goto recvfrom_loop"))
            (c-else
             (c-cons (c-false) (c-false)))))
  (lambda (bytes&address)
    (values (car bytes&address) (cdr bytes&address))))

(end-c-stub)