/* -*- Mode: C -*-

   BSD Sockets Wrapper

   This code is written by Taylor Campbell and placed in the Public
   Domain.  All warranties are disclaimed.

   GC protection is of an equivocal nature in this file.  It ought to
   be inspected thoroughly.  (Well, really, Scheme48 ought to have a
   much more rigorously designed GC protection mechanism like Pika's.
   Then all C wrappers wouldn't have to be rewritten if Scheme48 were
   to be made multithreaded.)
*/

/*** Inclusions ***/

#include <unistd.h>
#include <string.h>
#include <errno.h>
#include <sys/types.h>
#include <strings.h>
#include <fcntl.h>
#include <stdio.h>

#include <sys/socket.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#include <sys/un.h>

#include <scheme48.h>

/* Scheme48's c-mods.h */
#define PSTRUE  (0 == 0)
#define PSFALSE (0 != 0)
#define psbool  char

extern psbool                   /* Scheme48's event.h */
s48_add_pending_fd (int fd, psbool input_p);

extern int                      /* Scheme48's fd-io.h */
ps_close_fd (long fd);

/*** Macros ***/

#define RETRY(STATUS_LOC, CALL, TEST)           \
  while ((STATUS_LOC) = (CALL), (TEST))

/* This expects SYSCALL_LOSE to be defined wherever it is called. */
#define RETRY_OR_LOSE(STATUS_LOC, CALL, TEST)   \
  RETRY (STATUS_LOC, CALL, TEST)                \
    if (errno != EINTR)                         \
      SYSCALL_LOSE ()

/* This is the usual definition. */
#define SYSCALL_LOSE() return (s48_enter_integer (((long) errno)))

#define NONBLOCK(FD)                                            \
  {                                                             \
    int status;                                                 \
    RETRY_OR_LOSE (status,                                      \
                   (fcntl (FD, F_SETFL, O_NONBLOCK)),           \
                   (status < 0));                               \
  }

#define S48_CHANNEL_FD(CHANNEL)                                 \
  ((int) (s48_extract_fixnum ((S48_CHANNEL_OS_INDEX (CHANNEL)))))

#define S48_ADD_CHANNEL_OR_LOSE(CHANNEL_LOC, STATUS, ID, FD)    \
  (CHANNEL_LOC) = (s48_add_channel (STATUS, ID, FD));           \
  if (! (S48_CHANNEL_P (CHANNEL_LOC)))                          \
    {      /* Scheme48 exception number if not channel */       \
      ps_close_fd (((long) FD));                                \
      s48_raise_scheme_exception                                \
        ((s48_extract_fixnum (CHANNEL_LOC)), 0);                \
    }

#define S48_ADD_PENDING_FD_OR_LOSE(CHANNEL, INPUT_P)    \
  if (! (s48_add_pending_fd (CHANNEL, INPUT_P)))        \
    s48_raise_out_of_memory_error ()

/* Random utilities; these need better places to go. */

static s48_value
s48_dup_channel (s48_value old_channel_s48,
                 s48_value status_s48,
                 s48_value id_s48)
{
  int           old_fd, new_fd;
  s48_value     new_channel_s48;

  old_fd = (S48_CHANNEL_FD (old_channel_s48));

  RETRY_OR_LOSE (new_fd, (dup (old_fd)),
                 (new_fd < 0));

  NONBLOCK (new_fd);

  S48_ADD_CHANNEL_OR_LOSE (new_channel_s48, status_s48, id_s48,
                           new_fd);

  return new_channel_s48;
}

static s48_value
s48_strerror (s48_value errno_s48)
{
  return (s48_enter_string
          ((strerror (((int) (s48_extract_integer (errno_s48)))))));
}

#define ENTER_SOCKADDR(ADDRESS_S48, ADDRESS, ADDRESS_LEN)       \
  (ADDRESS_S48) =                                               \
    (s48_make_byte_vector (((long) ADDRESS_LEN)));              \
  memcpy ((S48_EXTRACT_VALUE_POINTER (ADDRESS_S48, void)),      \
          ((void *) (& ADDRESS)),                               \
          ((size_t) ADDRESS_LEN))

#define EXTRACT_SOCKADDR(ADDRESS_S48, ADDRESS_PTR, ADDRESS_LEN) \
  (ADDRESS_PTR) =                                               \
    (S48_EXTRACT_VALUE_POINTER (ADDRESS_S48,                    \
                                struct sockaddr));              \
  (ADDRESS_LEN) =                                               \
    ((socklen_t) (S48_BYTE_VECTOR_LENGTH (ADDRESS_S48)))

/*** Create & Shutdown ***/

static s48_value
s48_create_socket (s48_value domain_s48,
                   s48_value type_s48,
                   s48_value protocol_s48,
                   s48_value channel_id_s48)
{
  int           domain, type, protocol;
  int           socket_fd;
  s48_value     channel_s48 = (S48_FALSE);

  domain        = ((int) (s48_extract_fixnum (domain_s48)));
  type          = ((int) (s48_extract_fixnum (type_s48)));
  protocol      = ((int) (s48_extract_fixnum (protocol_s48)));

  RETRY_OR_LOSE (socket_fd, (socket (domain, type, protocol)),
                 (socket_fd < 0));

  NONBLOCK (socket_fd);

  S48_ADD_CHANNEL_OR_LOSE (channel_s48,
                           (S48_CHANNEL_STATUS_INPUT),
                           channel_id_s48,
                           socket_fd);

  return channel_s48;
}

static s48_value
s48_create_socket_pair (s48_value domain_s48,
                        s48_value type_s48,
                        s48_value protocol_s48,
                        s48_value channel0_id_s48,
                        s48_value channel1_id_s48)
{
  int domain, type, protocol, sv[2], status;
  s48_value channel0_s48 = (S48_FALSE), channel1_s48 = (S48_FALSE);

  S48_DECLARE_GC_PROTECT (4);

  domain        = ((int) (s48_extract_fixnum (domain_s48)));
  type          = ((int) (s48_extract_fixnum (type_s48)));
  protocol      = ((int) (s48_extract_fixnum (protocol_s48)));

  RETRY_OR_LOSE (status, (socketpair (domain, type, protocol, sv)),
                 (status < 0));

  S48_GC_PROTECT_4 (channel0_id_s48, channel0_s48,
                    channel1_id_s48, channel1_s48);

  S48_ADD_CHANNEL_OR_LOSE (channel0_s48, (S48_CHANNEL_STATUS_INPUT),
                           channel0_id_s48,
                           sv[0]);
  S48_ADD_CHANNEL_OR_LOSE (channel1_s48, (S48_CHANNEL_STATUS_INPUT),
                           channel1_id_s48,
                           sv[1]);

  S48_GC_UNPROTECT ();

  return (s48_cons (channel0_s48, channel1_s48));
}

static s48_value
s48_shutdown_socket (s48_value channel_s48,
                     s48_value how_s48)
{
  int socket_fd, how, status;

  socket_fd     = (S48_CHANNEL_FD (channel_s48));
  how           = ((int) (s48_extract_fixnum (how_s48)));

  RETRY_OR_LOSE (status, (shutdown (socket_fd, how)),
                 (status < 0));

  return (S48_FALSE);
}

/*** Bind, Listen, & Address Access ***/

static s48_value
s48_bind_socket (s48_value channel_s48,
                 s48_value address_s48)
{
  int                   socket_fd, status;
  struct sockaddr      *address_ptr;
  socklen_t             address_len;

  socket_fd = (S48_CHANNEL_FD (channel_s48));

  EXTRACT_SOCKADDR (address_s48, address_ptr, address_len);

  RETRY_OR_LOSE (status, (bind (socket_fd, address_ptr, address_len)),
                 (status < 0));

  return (S48_FALSE);
}

static s48_value
s48_listen_socket (s48_value channel_s48,
                   s48_value backlog_s48)
{
  int socket_fd, backlog, status;

  socket_fd     = (S48_CHANNEL_FD (channel_s48));
  backlog       = ((int) (s48_extract_integer (backlog_s48)));

  RETRY_OR_LOSE (status, (listen (socket_fd, backlog)),
                 (status < 0));

  return (S48_FALSE);
}

#define GET_ADDRESS(SYSCALL)                                    \
  int                           socket_fd, status;              \
  struct sockaddr_storage       address;                        \
  socklen_t                     address_len =                   \
    (sizeof (address));                                         \
  s48_value                     address_s48 = (S48_FALSE);      \
                                                                \
  S48_DECLARE_GC_PROTECT (1);                                   \
                                                                \
  socket_fd = (S48_CHANNEL_FD (channel_s48));                   \
                                                                \
  RETRY_OR_LOSE (status,                                        \
                 (SYSCALL (socket_fd,                           \
                           ((struct sockaddr *) (& address)),   \
                           (& address_len))),                   \
                 (status < 0));                                 \
                                                                \
  S48_GC_PROTECT_1 (address_s48);                               \
                                                                \
  ENTER_SOCKADDR (address_s48, address, address_len);           \
                                                                \
  S48_GC_UNPROTECT ();                                          \
                                                                \
  return (address_s48);

static s48_value
s48_socket_local_address (s48_value channel_s48)
{
  GET_ADDRESS (getsockname);
}

static s48_value
s48_socket_remote_address (s48_value channel_s48)
{
  GET_ADDRESS (getpeername);
}

/*** Sending & Receiving Datagrams ***/

#define S48_BYTE_VECTOR_RANGE(BYTEV_S48, START_S48, END_S48,    \
                              TYPE, PTR, LENGTH)                \
  (PTR) = (S48_EXTRACT_VALUE_POINTER (BYTEV_S48, TYPE));        \
                                                                \
  {                                                             \
    long start, end;                                            \
                                                                \
    start       = (s48_extract_fixnum (START_S48));             \
    end         = (s48_extract_fixnum (END_S48));               \
                                                                \
    (PTR)      += start;                                        \
    (LENGTH)    = (end - start);                                \
  }

#define WITHOUT_ADDRESS(SYSCALL, INPUT_P)                       \
  int           socket_fd, flags, count;                        \
  char         *message_ptr;                                    \
  size_t        message_len;                                    \
                                                                \
  socket_fd     = (S48_CHANNEL_FD (channel_s48));               \
  flags         = ((int) (s48_extract_fixnum (flags_s48)));     \
                                                                \
  S48_BYTE_VECTOR_RANGE (bytev_s48, start_s48, end_s48,         \
                         char, message_ptr, message_len);       \
                                                                \
  RETRY (count, (SYSCALL (socket_fd,                            \
                          ((void *) message_ptr),               \
                          message_len,                          \
                          flags)),                              \
         ((count < 0) && (errno == EINTR)));                    \
                                                                \
  if (count >= 0)                                               \
    return (s48_cons ((S48_TRUE),  /* True: win */              \
                      (s48_enter_integer (((long) count)))));   \
                                                                \
  if ((errno != EWOULDBLOCK) && (errno != EAGAIN))              \
    return (s48_cons ((S48_FALSE), /* False: lose */            \
                      (s48_enter_integer (((long) errno)))));   \
                                                                \
  S48_ADD_PENDING_FD_OR_LOSE (socket_fd, INPUT_P);              \
                                                                \
  /* False -> block */                                          \
  return (S48_FALSE)

static s48_value
s48_socket_send (s48_value channel_s48,
                 s48_value bytev_s48,
                 s48_value start_s48,
                 s48_value end_s48,
                 s48_value flags_s48)
{
  WITHOUT_ADDRESS (send, PSFALSE); /* False -> output */
}

static s48_value
s48_socket_recv (s48_value channel_s48,
                 s48_value bytev_s48,
                 s48_value start_s48,
                 s48_value end_s48,
                 s48_value flags_s48)
{
  WITHOUT_ADDRESS (recv, PSTRUE); /* True -> input */
}

static s48_value
s48_socket_sendto (s48_value channel_s48,
                   s48_value address_s48,
                   s48_value bytev_s48,
                   s48_value start_s48,
                   s48_value end_s48,
                   s48_value flags_s48)
{
  int                   socket_fd, flags, sent;
  struct sockaddr      *address_ptr;
  socklen_t             address_len;
  char                 *message_ptr;
  size_t                message_len;

  socket_fd     = (S48_CHANNEL_FD (channel_s48));
  flags         = ((int) (s48_extract_fixnum (flags_s48)));

  S48_BYTE_VECTOR_RANGE (bytev_s48, start_s48, end_s48,
                         char, message_ptr, message_len);

  EXTRACT_SOCKADDR (address_s48, address_ptr, address_len);

  RETRY (sent, (sendto (socket_fd,
                        ((void *) message_ptr),
                        message_len,
                        flags,
                        address_ptr,
                        address_len)),
         ((sent < 0) && (errno == EINTR)));

  if (sent >= 0)
    return (s48_cons ((S48_TRUE), /* True: win */
                      (s48_enter_integer (((long) sent)))));

  if ((errno != EWOULDBLOCK) && (errno != EAGAIN))
    return (s48_cons ((S48_FALSE), /* False: lose */
                      (s48_enter_integer (((long) errno)))));

  S48_ADD_PENDING_FD_OR_LOSE (socket_fd,
                              /* False -> output */
                              PSFALSE);

  return (S48_FALSE);           /* False -> block */
}

static s48_value
s48_socket_recvfrom (s48_value channel_s48,
                     s48_value bytev_s48,
                     s48_value start_s48,
                     s48_value end_s48,
                     s48_value flags_s48)
{
  int                           socket_fd, flags, received;
  struct sockaddr_storage       address;
  socklen_t                     address_len = (sizeof (address));
  char                         *message_ptr;
  size_t                        message_len;

  socket_fd     = (S48_CHANNEL_FD (channel_s48));
  flags         = ((int) (s48_extract_fixnum (flags_s48)));

  S48_BYTE_VECTOR_RANGE (bytev_s48, start_s48, end_s48,
                         char, message_ptr, message_len);

  RETRY (received, (recvfrom (socket_fd,
                              ((void *) message_ptr),
                              message_len,
                              flags,
                              ((struct sockaddr *) (& address)),
                              (& address_len))),
         ((received < 0) && (errno == EINTR)));

  if (received >= 0)
    {
      s48_value received_s48    = S48_FALSE;
      s48_value address_s48     = S48_FALSE;

      S48_DECLARE_GC_PROTECT (2);
      S48_GC_PROTECT_2 (received_s48, address_s48);

      received_s48 = (s48_enter_integer (((long) received)));

      ENTER_SOCKADDR (address_s48, address, address_len);

      S48_GC_UNPROTECT ();

      return (s48_cons (received_s48, address_s48));
    }

  if ((errno != EWOULDBLOCK) && (errno != EAGAIN))
    return (s48_enter_integer (((long) errno)));

  S48_ADD_PENDING_FD_OR_LOSE (socket_fd,
                              /* True -> input */
                              PSTRUE);

  return (S48_FALSE);           /* False -> block */
}

/*** Connecting & Accepting ***/

static s48_value
s48_connect_socket (s48_value channel_s48,
                    s48_value address_s48,
                    s48_value retrying_p_s48)
{
  int                   socket_fd, status;
  struct sockaddr      *address_ptr;
  socklen_t             address_len;

  socket_fd = (S48_CHANNEL_FD (channel_s48));

  EXTRACT_SOCKADDR (address_s48, address_ptr, address_len);

  RETRY (status, (connect (socket_fd,
                           address_ptr,
                           address_len)),
         ((status <= 0) && (errno == EINTR)));

  if ((0 <= status) ||
      ((errno == EISCONN) &&
       (S48_EXTRACT_BOOLEAN (retrying_p_s48))))
    return (S48_TRUE);

  if ((errno != EWOULDBLOCK)    &&
      (errno != EAGAIN)         &&
      (errno != EALREADY)       &&
      (errno != EINPROGRESS))
    return (s48_enter_integer (((long) errno)));

  S48_ADD_PENDING_FD_OR_LOSE (socket_fd,
                              /* False -> output */
                              PSFALSE);

  return (S48_FALSE);
}

static s48_value
s48_accept_connection (s48_value listen_channel_s48,
                       s48_value channel_id_s48)
{
  int                           listen_fd, accept_fd;
  struct sockaddr_storage       address;
  socklen_t                     address_len = (sizeof (address));

  listen_fd = (S48_CHANNEL_FD (listen_channel_s48));

  RETRY (accept_fd, (accept (listen_fd,
                             ((struct sockaddr *) (& address)),
                             (& address_len))),
         ((accept_fd < 0) && (errno == EINTR)));

  if (accept_fd >= 0)
    {
      s48_value accept_channel_s48      = (S48_FALSE);
      s48_value address_s48             = (S48_FALSE);

      S48_DECLARE_GC_PROTECT (3);

      NONBLOCK (accept_fd);

      S48_GC_PROTECT_3 (accept_channel_s48,
                        channel_id_s48,
                        address_s48);

      S48_ADD_CHANNEL_OR_LOSE (accept_channel_s48,
                               (S48_CHANNEL_STATUS_INPUT),
                               channel_id_s48,
                               accept_fd);

      ENTER_SOCKADDR (address_s48, address, address_len);

      S48_GC_UNPROTECT ();

      return (s48_cons (accept_channel_s48, address_s48));
    }

  /* Are these two errno values the same by POSIX, or do Darwin, Linux,
     & Solaris all just happen to define them to be the same? */
  if ((errno != EWOULDBLOCK) && (errno != EAGAIN))
    return (s48_enter_integer (((long) errno)));

  S48_ADD_PENDING_FD_OR_LOSE (listen_fd,
                              /* True -> input */
                              PSTRUE);

  return (S48_FALSE);
}

/*** Socket Options ***/

#define SOCKET_OPTION(TYPE)                                     \
  int fd, level, optname, status;                               \
  TYPE optval;                                                  \
  socklen_t optlen = (sizeof (optval));                         \
                                                                \
  fd            = (S48_CHANNEL_FD (channel_s48));               \
  level         = ((int) (s48_extract_fixnum (level_s48)));     \
  optname       = ((int) (s48_extract_fixnum (optname_s48)));   \
                                                                \
  RETRY_OR_LOSE (status,                                        \
                 (getsockopt (fd, level, optname,               \
                              ((void *) (& optval)),            \
                              (& optlen))),                     \
                 (status < 0))

static s48_value
s48_boolean_socket_option (s48_value channel_s48,
                           s48_value level_s48,
                           s48_value optname_s48)
{
  SOCKET_OPTION (int);

  return ((optval == 0)
          ? (S48_FALSE)
          : (S48_TRUE));
}

static s48_value
s48_integer_socket_option (s48_value channel_s48,
                           s48_value level_s48,
                           s48_value optname_s48)
{
  /* We need to tag the result here if it's an errno integer and not
     the option's value, since both are integers. */
#define SYSCALL_LOSE()                                          \
  return (s48_cons ((S48_FALSE),                                \
                    (s48_enter_integer (((long) errno)))))

  SOCKET_OPTION (int);

  return (s48_cons ((S48_TRUE),
                    (s48_enter_integer (((long) optval)))));
}

static s48_value
s48_linger_socket_option (s48_value channel_s48,
                          s48_value level_s48,
                          s48_value optname_s48)
{
  /* Same here with syscall lossage as in integer_socket_option(). */

  SOCKET_OPTION (struct linger);

  return (s48_cons ((S48_TRUE),
                    (((optval.l_onoff) == 0)
                     ? (S48_FALSE)
                     : (s48_enter_integer
                        (((long) (optval.l_linger)))))));
}

static s48_value
s48_timeout_socket_option (s48_value channel_s48,
                           s48_value level_s48,
                           s48_value optname_s48)
{
  s48_value seconds_s48         = (S48_FALSE);
  s48_value milliseconds_s48    = (S48_FALSE);

  S48_DECLARE_GC_PROTECT (2);

  /* Back to normal syscall lossage of returning errno straight. */
#define SYSCALL_LOSE() return (s48_enter_integer (((long) errno)))

  SOCKET_OPTION (struct timeval);

  S48_GC_PROTECT_2 (seconds_s48, milliseconds_s48);

  seconds_s48      = (s48_enter_integer (((long) (optval.tv_sec))));
  milliseconds_s48 = (s48_enter_integer (((long) (optval.tv_usec))));

  S48_GC_UNPROTECT ();

  return (s48_cons (seconds_s48, milliseconds_s48));
}

#define SET_SOCKET_OPTION(TYPE, PRELUDE)                        \
  int fd, level, optname, status;                               \
  TYPE optval;                                                  \
                                                                \
  PRELUDE                                                       \
                                                                \
  fd            = (S48_CHANNEL_FD (channel_s48));               \
  level         = ((int) (s48_extract_fixnum (level_s48)));     \
  optname       = ((int) (s48_extract_fixnum (optname_s48)));   \
                                                                \
  RETRY_OR_LOSE (status,                                        \
                 (setsockopt (fd, level, optname,               \
                              ((const void *) (& optval)),      \
                              (sizeof (optval)))),              \
                 (status < 0));                                 \
                                                                \
  return (S48_FALSE)

static s48_value
s48_set_boolean_socket_option (s48_value channel_s48,
                               s48_value level_s48,
                               s48_value optname_s48,
                               s48_value optval_s48)
{
  SET_SOCKET_OPTION
    (int, { optval = ((int) (S48_EXTRACT_BOOLEAN (optval_s48))); });
}

static s48_value
s48_set_integer_socket_option (s48_value channel_s48,
                               s48_value level_s48,
                               s48_value optname_s48,
                               s48_value optval_s48)
{
  SET_SOCKET_OPTION
    (int, { optval = ((int) (s48_extract_integer (optval_s48))); });
}

static s48_value
s48_set_linger_socket_option (s48_value channel_s48,
                              s48_value level_s48,
                              s48_value optname_s48,
                              s48_value optval_s48)
{
  SET_SOCKET_OPTION
    (struct linger,
     {
       bzero (((void *) (& optval)), (sizeof (optval)));
       if (S48_EXTRACT_BOOLEAN (optval_s48))
         {
           (optval.l_onoff) = 1;
           (optval.l_linger) =
             ((int) (s48_extract_integer (optval_s48)));
         }
     });
}

static s48_value
s48_set_timeout_socket_option (s48_value channel_s48,
                               s48_value level_s48,
                               s48_value optname_s48,
                               s48_value seconds_s48,
                               s48_value milliseconds_s48)
{
  SET_SOCKET_OPTION
    (struct timeval,
     {
       bzero (((void *) (& optval)), (sizeof (optval)));
       (optval.tv_sec) =
         ((time_t) (s48_extract_integer (seconds_s48)));
       (optval.tv_usec) =
         ((suseconds_t) (s48_extract_integer (milliseconds_s48)));
     });
}

/*** Scheme48 Shared Binding Initialization ***/

void
s48_on_load (void)
{
  S48_EXPORT_FUNCTION (s48_dup_channel);

  S48_EXPORT_FUNCTION (s48_strerror);

  S48_EXPORT_FUNCTION (s48_create_socket);
  S48_EXPORT_FUNCTION (s48_create_socket_pair);
  S48_EXPORT_FUNCTION (s48_shutdown_socket);

  S48_EXPORT_FUNCTION (s48_bind_socket);
  S48_EXPORT_FUNCTION (s48_listen_socket);

  S48_EXPORT_FUNCTION (s48_socket_local_address);
  S48_EXPORT_FUNCTION (s48_socket_remote_address);

  S48_EXPORT_FUNCTION (s48_socket_send);
  S48_EXPORT_FUNCTION (s48_socket_recv);
  S48_EXPORT_FUNCTION (s48_socket_sendto);
  S48_EXPORT_FUNCTION (s48_socket_recvfrom);

  S48_EXPORT_FUNCTION (s48_connect_socket);
  S48_EXPORT_FUNCTION (s48_accept_connection);

  S48_EXPORT_FUNCTION (s48_boolean_socket_option);
  S48_EXPORT_FUNCTION (s48_integer_socket_option);
  S48_EXPORT_FUNCTION (s48_linger_socket_option);
  S48_EXPORT_FUNCTION (s48_timeout_socket_option);

  S48_EXPORT_FUNCTION (s48_set_boolean_socket_option);
  S48_EXPORT_FUNCTION (s48_set_integer_socket_option);
  S48_EXPORT_FUNCTION (s48_set_linger_socket_option);
  S48_EXPORT_FUNCTION (s48_set_timeout_socket_option);
}

void
s48_on_reload (void)
{
  s48_on_load ();
}