/*
 * mzsocket: BSD/POSIX sockets library for mzscheme
 * Copyright (C) 2007 Dimitris Vyzovitis <vyzo@media.mit.edu>
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 * 
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, 
 * USA
 */
#include "_socket.h"

#define SYMBOL scheme_intern_symbol
#define FIXNUM scheme_make_integer
#define FLONUM scheme_make_double
#define BOOLEAN(x) ((x)? scheme_true : scheme_false)
#define BYTES scheme_make_byte_string
#define BYTES_SIZE(x, sz) scheme_make_sized_byte_string(x, sz, 1)
#define PATH scheme_make_path
#define PATH_SIZE(x, sz) scheme_make_sized_path(x, sz, 1)
#define STRING_TO_BYTES scheme_char_string_to_byte_string_locale
#define LIST scheme_build_list

#define FIXNUM_VAL SCHEME_INT_VAL
#define FLONUM_VAL SCHEME_FLOAT_VAL
#define BOOLEAN_VAL(x) (SCHEME_FALSEP(x)? 0 : 1)
#define STRING_VAL SCHEME_CHAR_STR_VAL
#define BYTES_VAL SCHEME_BYTE_STR_VAL
#define BYTES_LEN SCHEME_BYTE_STRLEN_VAL
#define PATH_VAL SCHEME_PATH_VAL
#define PATH_LEN SCHEME_PATH_LEN
#define LIST_LEN scheme_list_length
#define VECTOR_LEN SCHEME_VEC_SIZE
#define VECTOR_REF(x, i) (SCHEME_VEC_ELS(x)[i])
#define VECTOR(len, els) (scheme_list_to_vector(scheme_build_list(len, els)))

#define FIXNUMP SCHEME_INTP
#define BYTESP SCHEME_BYTE_STRINGP
#define NULLP SCHEME_NULLP
#define PATHP SCHEME_PATHP
#define CAR SCHEME_CAR
#define CDR SCHEME_CDR


#define INET_ADDRESSP(obj) \
  (SAME_TYPE(SCHEME_TYPE(obj), inet_address_tag))
#define SOCKETP(obj) \
  (SAME_TYPE(SCHEME_TYPE(obj), sock_tag))

#define EXPECT_BOOLEAN(where, arg) \
  if (!SCHEME_BOOLP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected boolean, given ", argv[arg] )
#define EXPECT_FIXNUM(where, arg) \
  if (!SCHEME_INTP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected fixnum, given ", argv[arg] )
#define EXPECT_FLONUM(where, arg) \
  if (!SCHEME_FLOATP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected flonum, given ", argv[arg] )
#define EXPECT_STRING(where, arg) \
  if (!SCHEME_CHAR_STRINGP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected string, given ", argv[arg] )
#define EXPECT_BYTES(where, arg) \
  if (!SCHEME_BYTE_STRINGP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected bytes, given ", argv[arg] )
#define EXPECT_BYTES_OR_FALSE(where, arg) \
  if (!(SCHEME_BYTE_STRINGP( argv[arg] ) || SCHEME_FALSEP( argv[arg] ))) \
    scheme_arg_mismatch( where, "expected bytes, given ", argv[arg] )
#define EXPECT_MUTABLE_BYTES(where, arg) \
  if (!SCHEME_MUTABLE_BYTE_STRINGP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected mutable bytes, given ", argv[arg] )
#define EXPECT_MUTABLE_BYTES_OR_FALSE(where, arg) \
  if (!(SCHEME_MUTABLE_BYTE_STRINGP( argv[arg] ) \
        || SCHEME_FALSEP( argv[arg] ))) \
    scheme_arg_mismatch( where, "expected mutable bytes, given ", argv[arg] )
#define EXPECT_PATH(where, arg) \
  if (!SCHEME_PATHP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected path, given ", argv[arg] )
#define EXPECT_PAIR(where, arg) \
  if (!SCHEME_PAIRP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected pair, given ", argv[arg] )
#define EXPECT_VECTOR(where, arg) \
  if (!SCHEME_VECTORP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected vector, given ", argv[arg] )
#define EXPECT_INET_ADDRESS(where, arg) \
  if (!INET_ADDRESSP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected inet-address, given ", argv[arg] )
#define EXPECT_SOCKET(where, arg) \
  if (!SOCKETP( argv[arg] )) \
    scheme_arg_mismatch( where, "expected socket, given ", argv[arg] )

#define CHECK_RANGE(where, bs, b, e) \
  if (!((b >= 0) && (e > b) && (e <= BYTES_LEN(bs)))) \
    scheme_raise_exn( MZEXN_FAIL_CONTRACT, "%s: bad range %d %d %d", \
                      where, BYTES_LEN(bs), b, e )

#define FAIL(how) scheme_raise_exn( MZEXN_FAIL, how )
#define FAIL2(where, how) scheme_raise_exn( MZEXN_FAIL, "%s: %s", where, how )

#ifndef MIN
#define MIN(x, y) (((x) < (y))? (x) : (y))
#endif

#ifdef MZ_PRECISE_GC
#define BEGIN_XFORM START_XFORM_SKIP;
#define END_XFORM END_XFORM_SKIP;
#define BEGIN_ALLOW_XFORM END_XFORM_SKIP;
#define END_ALLOW_XFORM START_XFORM_SKIP;
#define REGISTER_GC(tag, SIZE, MARK, FIXUP, c, a) \
  GC_register_traversers(tag, SIZE, MARK, FIXUP, c, a)
#else
#define BEGIN_XFORM
#define END_XFORM
#define BEGIN_ALLOW_XFORM
#define END_ALLOW_XFORM
#define REGISTER_GC(tag, SIZE, MARK, FIXUP, c, a)
#endif

#define REGISTER_STATIC(x) \
  scheme_register_static((void *)&x, sizeof(x))

#define EXPORT_PROC(name, p, arity) \
  scheme_add_global( name, \
    scheme_make_prim_w_arity( p, name, arity, arity ), module )
#define EXPORT_VPROC(name, p, arity) \
  scheme_add_global( name, \
    scheme_make_prim_w_arity( p, name, arity, -1 ), module )
#define EXPORT_VAL(name, val) \
  scheme_add_global( name, val, module )

// types
static Scheme_Object* exn_type;
static Scheme_Type inet_address_tag;
static Scheme_Type sock_tag;
static Scheme_Type sock_evt_tag;

typedef struct {
  Scheme_Object tag;
  int family;
  union {
    struct sockaddr_in sa_in;
    struct sockaddr_in6 sa_in6;
  } sa;
} inet_address;

typedef struct {
  Scheme_Object tag;
  Scheme_Custodian_Reference* custodian;
  fd_t fd;
  int domain;
} sock;

enum evt_t {
  evt_read = 0x01,
  evt_write = 0x02,
  evt_except = 0x04
};

typedef struct {
  Scheme_Object tag;
  sock* s;
  enum evt_t t;
} sock_evt;


// xform has some trouble with this code. Besides, there are a few
// places where it is needed (most functions don't call scheme functions
// that can trigger gc in the middle of execution)
// so the default is to not xform and explicitly mark xform areas with
// BEIN/END_ALLOW_XFORM blocks

BEGIN_XFORM
BEGIN_ALLOW_XFORM
// struct: (exn:socket exn:fail:network) (errno)
static Scheme_Object* new_exn( const char* pre, int err ) {
  Scheme_Object* vals[3];
  char msg[256];
  int r;
  
  r = snprintf( msg, sizeof( msg ), "%s: %s [%d]", pre, strerror( err ), err );
  if (r > sizeof( msg )) // uhm
    msg[sizeof(msg)-1] = 0;
  
  vals[0] = scheme_make_locale_string( msg );
  SCHEME_SET_CHAR_STRING_IMMUTABLE( vals[0] );
  vals[1] = scheme_current_continuation_marks( NULL );
  vals[2] = FIXNUM( err );
  return scheme_make_struct_instance( exn_type, 3, vals );
}
END_ALLOW_XFORM

static Scheme_Object* make_exn( int argc, Scheme_Object** argv ) {
  EXPECT_STRING( "make-exn:socket", 0 );
  EXPECT_FIXNUM( "make-exn:socket", 1 );
  return new_exn( BYTES_VAL( STRING_TO_BYTES( argv[0] )), 
                  FIXNUM_VAL( argv[1] ));
}


static Scheme_Object* exn_errno( int argc, Scheme_Object** argv ) {
  return scheme_struct_ref( argv[0], 2 );
}

static Scheme_Object* exn_p( int argc, Scheme_Object** argv ) {
  return BOOLEAN( scheme_is_struct_instance( exn_type, argv[0] ));
}

// inet-address
static Scheme_Object* new_inet_address( int family, void* sa ) {
  inet_address* ina;
  ina = (inet_address*)scheme_malloc_tagged( sizeof(inet_address) );
  ina->tag.type = inet_address_tag;
  ina->family = family;
  switch (family) {
  case AF_INET:
    memcpy( &ina->sa.sa_in, sa, sizeof(struct sockaddr_in) );
    ina->sa.sa_in.sin_family = AF_INET;
    break;
#ifdef HAVE_IPV6
  case AF_INET6:
    memcpy( &ina->sa.sa_in6, sa, sizeof(struct sockaddr_in6) );
    ina->sa.sa_in6.sin6_family = AF_INET6;
    break;
#endif
  }

  return (Scheme_Object*)ina;
}

#ifdef WINDOWS
// how about I give you the finger and you give me my phonecall...
static int inet_pton( int af, const char* src, void* dst ) {
  switch (af) {
  case AF_INET: {
    struct sockaddr_in sa;
    int len = sizeof(sa);
    sa.sin_family = AF_INET;
    if (!WSAStringToAddress((LPTSTR)src, af, NULL, 
                            (LPSOCKADDR)&sa, &len)) {
      memcpy( dst, &sa.sin_addr, sizeof(struct in_addr) );
      return 1;
    } else return -1;
  }
#ifdef HAVE_IPV6
  case AF_INET6: {
    struct sockaddr_in6 sa;
    int len = sizeof(sa);
    sa.sin6_family = AF_INET6;
    if (!WSAStringToAddress((LPTSTR)src, af, NULL, 
                            (LPSOCKADDR)&sa, &len)) {
      memcpy( dst, &sa.sin6_addr, sizeof(struct in6_addr) );
      return 1;
    } else return -1;
  }
#endif
  }
}

static char* inet_ntop( int af, const void* src, char* dst, size_t dstlen ) {
  switch (af) {
  case AF_INET: {
    struct sockaddr_in sa;
    DWORD len = dstlen;
    sa.sin_family = AF_INET;
    memcpy( &sa.sin_addr, src, sizeof(struct in_addr) );
    if (!WSAAddressToString( (LPSOCKADDR)&sa, (DWORD)sizeof(sa), 
                             NULL, (LPTSTR)dst, &len ))
      return dst;
    else return NULL;
  }
#ifdef HAVE_IPV6
  case AF_INET6: {
    struct sockaddr_in6 sa;
    DWORD len = dstlen;
    sa.sin6_family = AF_INET6;
    memcpy( &sa.sin6_addr, src, sizeof(struct in6_addr) );
    if (!WSAAddressToString( (LPSOCKADDR)&sa, (DWORD)sizeof(sa), 
                             NULL, (LPTSTR)dst, &len ))
      return dst;
    else return NULL;
  }
#endif
  }
}
#endif

static Scheme_Object* make_inet_address( int argc, Scheme_Object** argv ) {
  union {
    struct sockaddr_in sa_in;
    struct sockaddr_in6 sa_in6;
  } sa;
  int family;
  
  EXPECT_FIXNUM( "make-inet-address", 0 );
  EXPECT_BYTES( "make-inet-address", 1 );
  EXPECT_FIXNUM( "make-inet-address", 2 );
  
  family = FIXNUM_VAL( argv[0] );
  switch (family) {
  case AF_INET:
    if (inet_pton( family, BYTES_VAL( argv[1] ), &sa.sa_in.sin_addr) > 0) {
      sa.sa_in.sin_port = htons((u16)FIXNUM_VAL(argv[2]));
      return new_inet_address( AF_INET, &sa.sa_in );
    } else goto err;

#ifdef HAVE_IPV6
  case AF_INET6:
    if (inet_pton( family, BYTES_VAL( argv[1] ), &sa.sa_in6.sin6_addr) > 0) {
      sa.sa_in6.sin6_port = htons((u16)FIXNUM_VAL(argv[2]));
    } else goto err;
    
    switch (argc) {
    case 3: 
      sa.sa_in6.sin6_flowinfo = 0;
      sa.sa_in6.sin6_scope_id = 0;
      break;
    case 5:
      EXPECT_FIXNUM( "make-inet-address", 3 );
      EXPECT_FIXNUM( "make-inet-address", 4 );
      sa.sa_in6.sin6_flowinfo = htonl((u32)FIXNUM_VAL(argv[3]));
      sa.sa_in6.sin6_scope_id = htonl((u32)FIXNUM_VAL(argv[4]));
      break;
    default:
      FAIL( "make-inet-address: bad arguments for inet6 address" );
    }
    
    return new_inet_address( AF_INET6, &sa.sa_in6 );
#endif    

  default:
    FAIL( "make-inet-address: unknown address family" );
  }
 
 err:
  scheme_raise( new_exn( "inet_pton", ERRNO ));
}

static Scheme_Object* inet_address_p( int argc, Scheme_Object** argv ) {
  return BOOLEAN( INET_ADDRESSP( argv[0] ));
}

static void print_inet_address( Scheme_Object* v, int dis, 
                                Scheme_Print_Params* pp ) {
  char buf[128];
  char pbuf[64];
  inet_address* ina = (inet_address*)v;
  int len;
  int srep;
  int proto, port;
  
  switch (ina->family) {
  case AF_INET:
    srep = (int)inet_ntop( AF_INET, &ina->sa.sa_in.sin_addr, 
                           pbuf, sizeof(pbuf));
    proto = 4;
    port = ntohs( ina->sa.sa_in.sin_port );
    break;
#ifdef HAVE_IPV6
  case AF_INET6:
    srep = (int)inet_ntop( AF_INET6, &ina->sa.sa_in6.sin6_addr, 
                           pbuf, sizeof(pbuf));
    proto = 6;
    port = ntohs( ina->sa.sa_in6.sin6_port );
    break;
#endif
  }
  
  len = snprintf( buf, sizeof(buf), "#<inet%d %s:%d>", 
                  proto, (srep? pbuf : "???"), port );
  scheme_print_bytes( pp, buf, 0, len );
}

static Scheme_Object* inet_address_family( int argc, Scheme_Object** argv ) {
  EXPECT_INET_ADDRESS( "inet-address-family", 0 );
  return FIXNUM( ((inet_address*)argv[0])->family );
}

static Scheme_Object* inet_ntop_bytes( int af, void* sa ) {
  char pbuf[64];
  if (inet_ntop( af, sa, pbuf, sizeof(pbuf) ))
    return BYTES( pbuf );
  else scheme_raise( new_exn( "inet_ntop", ERRNO ));
}

static Scheme_Object* inet_address_host( int argc, Scheme_Object** argv ) {
  char pbuf[64];
  int r;
  inet_address* ina;
  EXPECT_INET_ADDRESS( "inet-address-host", 0 );

  ina = (inet_address*)argv[0];
  switch (ina->family) {
  case AF_INET:
    return inet_ntop_bytes( AF_INET, &ina->sa.sa_in.sin_addr );
#ifdef HAVE_IPV6
  case AF_INET6:
    return inet_ntop_bytes( AF_INET6, &ina->sa.sa_in6.sin6_addr );
#endif
  }
}

static Scheme_Object* inet_address_port( int argc, Scheme_Object** argv ) {
  inet_address* ina;
  EXPECT_INET_ADDRESS( "inet-address-port", 0 );
  ina = (inet_address*)argv[0];
  switch (ina->family) {
  case AF_INET:
    return FIXNUM( ntohs( ina->sa.sa_in.sin_port ));
#ifdef HAVE_IPV6
  case AF_INET6:
    return FIXNUM( ntohs( ina->sa.sa_in6.sin6_port ));
#endif
  }
}

// general equality (369.8)
static int inet_address_equal( Scheme_Object* sx, Scheme_Object* sy ) {
  inet_address* x = (inet_address*)sx; 
  inet_address* y = (inet_address*)sy;
  
  if (x->family == y->family) {
    switch (x->family) {
    case AF_INET:
      return (x->sa.sa_in.sin_port == y->sa.sa_in.sin_port) 
        && (x->sa.sa_in.sin_addr.s_addr == y->sa.sa_in.sin_addr.s_addr);
#ifdef HAVE_IPV6
    case AF_INET6:
      return (x->sa.sa_in6.sin6_port == y->sa.sa_in6.sin6_port) 
        && !memcmp( x->sa.sa_in6.sin6_addr.s6_addr,
                    y->sa.sa_in6.sin6_addr.s6_addr,
                    16 )
        && (x->sa.sa_in6.sin6_flowinfo == y->sa.sa_in6.sin6_flowinfo)
        && (x->sa.sa_in6.sin6_scope_id == y->sa.sa_in6.sin6_scope_id);
#endif
    }
  } else return 0;
}

static long inet_address_hash1( Scheme_Object* x, long base ) {
  inet_address* ina = (inet_address*)x;
  switch (ina->family) {
  case AF_INET:
    return base ^ ina->sa.sa_in.sin_addr.s_addr;
#ifdef HAVE_IPV6
  case AF_INET6: {
    int i, j, k;
    for (i = 0; i < 4; i++) {
      k = 0;
      for (j = 0; j < 4; j++) {
        k |= ina->sa.sa_in6.sin6_addr.s6_addr[(i<<2)+j] << (j << 3);
      }
      base ^= k;
    }
    return base;
  }
#endif
  }
}

static long inet_address_hash2( Scheme_Object* x ) {
  inet_address* ina = (inet_address*)x;
  switch (ina->family) {
  case AF_INET:
    return inet_address_hash1( x, ina->sa.sa_in.sin_port );
#ifdef HAVE_IPV6
  case AF_INET6:
    return inet_address_hash1( x, ina->sa.sa_in6.sin6_port );
#endif
  }
}

// inet-addres=? (<inet-address> <inet-address> ...) => <bool>
static Scheme_Object* inet_address_equalp( int argc, Scheme_Object** argv ) {
  inet_address* x,y;
  int i;
  EXPECT_INET_ADDRESS( "inet-address=?", 0 );
  for (i = 1; i < argc; i++) {
    EXPECT_INET_ADDRESS( "inet-address=?", i );
    if (!inet_address_equal( argv[0], argv[i] ))
      return scheme_false;
  }
  
  return scheme_true;
}

// raw conversions
BEGIN_ALLOW_XFORM
static Scheme_Object* inet_address_to_vec( int argc, Scheme_Object** argv ) {
  inet_address* ina;
  EXPECT_INET_ADDRESS( "inet-address->vector", 0 );
  ina = (inet_address*)argv[0];
  switch (ina->family) {
  case AF_INET: {
    Scheme_Object* vec[3];
    vec[0] = FIXNUM( 4 );
    vec[1] = BYTES_SIZE( (char*)&ina->sa.sa_in.sin_addr.s_addr, 4 );
    vec[2] = FIXNUM( ina->sa.sa_in.sin_port );
    return VECTOR( 3, vec );
  }
#ifdef HAVE_IPV6
  case AF_INET6: {
    Scheme_Object* vec[5];
    vec[0] = FIXNUM( 6 );
    vec[1] = BYTES_SIZE( ina->sa.sa_in6.sin6_addr.s6_addr, 16 );
    vec[2] = FIXNUM( ina->sa.sa_in6.sin6_port );
    vec[3] = FIXNUM( ina->sa.sa_in6.sin6_flowinfo );
    vec[4] = FIXNUM( ina->sa.sa_in6.sin6_scope_id );
    return VECTOR( 5, vec );
  }
#endif
  }
}
END_ALLOW_XFORM

static Scheme_Object* vec_to_inet_address( int argc, Scheme_Object** argv ) {
  int len;
  EXPECT_VECTOR( "vector->inet-address", 0 );
  if (VECTOR_LEN( argv[0] ) < 1) goto err;
  if (FIXNUMP( VECTOR_REF( argv[0], 0 ))) {
    switch (FIXNUM_VAL( VECTOR_REF( argv[0], 0 ))) {
    case 4: {
      struct sockaddr_in sa;
      if (!((VECTOR_LEN( argv[0] ) == 3)
            && BYTESP( VECTOR_REF( argv[0], 1 ))
            && (BYTES_LEN( VECTOR_REF( argv[0], 1 )) == 4)
            && FIXNUMP( VECTOR_REF( argv[0], 2 ))))
        goto err;
      sa.sin_family = AF_INET;
      sa.sin_port = FIXNUM_VAL( VECTOR_REF( argv[0], 2 ));
      sa.sin_addr.s_addr = *(u32*)BYTES_VAL( VECTOR_REF( argv[0], 1 ));
      return new_inet_address( AF_INET, &sa );
    }
#ifdef HAVE_IPV6
    case 6: {
      struct sockaddr_in6 sa;
      if (!((VECTOR_LEN( argv[0] ) == 5)
            && BYTESP( VECTOR_REF( argv[0], 1 ))
            && (BYTES_LEN( VECTOR_REF( argv[0], 1 )) == 16)
            && FIXNUMP( VECTOR_REF( argv[0], 2 ))
            && FIXNUMP( VECTOR_REF( argv[0], 3 ))
            && FIXNUMP( VECTOR_REF( argv[0], 4 ))))
        goto err;
      sa.sin6_family = AF_INET6;
      sa.sin6_port = FIXNUM_VAL( VECTOR_REF( argv[0], 2 ));
      memcpy( sa.sin6_addr.s6_addr, BYTES_VAL( VECTOR_REF( argv[0], 1 )), 16);
      sa.sin6_flowinfo = FIXNUM_VAL( VECTOR_REF( argv[0], 3 ));
      sa.sin6_scope_id = FIXNUM_VAL( VECTOR_REF( argv[0], 4 ));
      return new_inet_address( AF_INET6, &sa );
    }
#endif
    default:
      FAIL( "vector->inet-address: uknown address family" );
    }
  }
 err:
  FAIL( "vector->inet-address: bad vector" );
}

#ifdef UNIX
static long unix_path_len( const char* path ) {
  long r;
  for (r = 0; r < UNIX_PATH_MAX; r++) if (*path++ == 0) break;
  return r;
}
#endif

// packing/unpacking
static Scheme_Object* pack_address( int argc, Scheme_Object** argv ) {
  if (INET_ADDRESSP( argv[0] )) {
    inet_address* ina = (inet_address*)argv[0];
    switch (ina->family) {
    case AF_INET: {
      struct sockaddr_in sa;
      memcpy( &sa, &ina->sa.sa_in, sizeof(sa) );
      return BYTES_SIZE( (char*)&sa, sizeof(sa) );
    }
#ifdef HAVE_IPV6
    case AF_INET6: {
      struct sockaddr_in6 sa;
      memcpy( &sa, &ina->sa.sa_in6, sizeof(sa) );
      return BYTES_SIZE( (char*)&sa, sizeof(sa) );
    }
#endif
    }
#ifdef UNIX    
  } else if (PATHP( argv[0] )) {
    struct sockaddr_un sa;
    memset( &sa, 0, sizeof(sa) );
    sa.sun_family = AF_UNIX;
    memcpy( sa.sun_path, PATH_VAL( argv[0] ),
            MIN(UNIX_PATH_MAX, PATH_LEN( argv[0] )));
    return BYTES_SIZE( (char*)&sa, sizeof(sa) );
#endif
  } else FAIL( "pack-address: unknown address family" );
}

static Scheme_Object* unpack_address( int argc, Scheme_Object** argv ) {
  EXPECT_BYTES( "unpack-address", 0 );
  if (BYTES_LEN( argv[0] ) < sizeof(struct sockaddr))
    FAIL( "unpack-address: bad byte string" );
  
  switch (((struct sockaddr*)BYTES_VAL( argv[0] ))->sa_family) {
  case AF_INET: {
    struct sockaddr_in sa_in;
    if (BYTES_LEN( argv[0] ) < sizeof(sa_in))
      FAIL( "unpack-address: bad byte string" );
    memcpy( &sa_in, BYTES_VAL( argv[0] ), sizeof(sa_in) );
    return new_inet_address( AF_INET, &sa_in );
  }
#ifdef HAVE_IPV6
  case AF_INET6: {
    struct sockaddr_in sa_in6;
    if (BYTES_LEN( argv[0] ) < sizeof(sa_in6))
      FAIL( "unpack-address: bad byte string" );
    memcpy( &sa_in6, BYTES_VAL( argv[0] ), sizeof(sa_in6) );
    return new_inet_address( AF_INET6, &sa_in6 );
  }
#endif
#ifdef UNIX
  case AF_UNIX: {
    struct sockaddr_un sa_un;
    if (BYTES_LEN( argv[0] ) < sizeof(sa_un))
      FAIL( "unpack-address: bad byte string" );
    memcpy( &sa_un, BYTES_VAL( argv[0] ), sizeof(sa_un) );
    return PATH_SIZE( sa_un.sun_path, unix_path_len( sa_un.sun_path ));
  }
#endif
  default:
    FAIL( "unpack-address: unknown address family" );
  }
}

// sock
static void _close_fd( fd_t fd ) {
  again:
  if ((close( fd ) < 0) && (ERRNO == EINTR)) 
    goto again;
}

static void _socket_close( sock* s ) {
  Scheme_Custodian_Reference* custodian;
  if (s->fd != INVALID) {
    _close_fd( s->fd );
    s->fd = INVALID;
    custodian = s->custodian;
    s->custodian = NULL;
    scheme_remove_managed( custodian, (Scheme_Object*)s );
  }
}

static void _socket_fin( void* obj, void* x ) {
  _socket_close( (sock*)obj );
}

static void setnonblock( fd_t fd ) {
  int flags;
#ifdef UNIX
  flags = fcntl( fd, F_GETFL, 0 );
  if ( flags < 0 ) {
    _close_fd( fd );
    scheme_raise( new_exn( "fcntl: GETFL", ERRNO ));
  }
  flags |= O_NONBLOCK;
  if ( fcntl( fd, F_SETFL, flags ) < 0 ) {
    _close_fd( fd );
    scheme_raise( new_exn( "fcntl: SETFL", ERRNO ));
  }

#else 
  flags = 1;
  if (ioctlsocket( fd, FIONBIO, (u_long FAR*)&flags )) // geez
    scheme_raise( new_exn( "ioctlsocket", ERRNO ));
#endif
}

BEGIN_ALLOW_XFORM
static Scheme_Object* new_socket( fd_t fd, int domain ) {
  sock* s;
  Scheme_Custodian_Reference* custodian;
  
  setnonblock( fd );
  s = (sock*)scheme_malloc_tagged( sizeof(sock) );
  s->tag.type = sock_tag;
  s->fd = fd;
  s->domain = domain;
  custodian = scheme_add_managed( NULL, 
                                  (Scheme_Object*)s, 
                                  (Scheme_Close_Custodian_Client*)_socket_fin,
                                  NULL, 
                                  0 ); // weak ref, allow gc
  s->custodian = custodian;
  scheme_add_finalizer( s, _socket_fin, NULL ); // auto close on gc
  return (Scheme_Object*)s;
}
END_ALLOW_XFORM

// (domain type proto)
static Scheme_Object* make_socket( int argc, Scheme_Object** argv ) {
  int domain, type, proto;
  fd_t fd;
  
  EXPECT_FIXNUM( "socket", 0 );
  EXPECT_FIXNUM( "socket", 1 );
  EXPECT_FIXNUM( "socket", 2 );
  
  domain = FIXNUM_VAL( argv[0] );
  type = FIXNUM_VAL( argv[1] );
  proto = FIXNUM_VAL( argv[2] );

  if ((fd = socket( domain, type, proto )) == INVALID) {
    scheme_raise( new_exn( "socket", ERRNO ));
  }
  
  return new_socket( fd, domain );
}

static Scheme_Object* socket_p( int argc, Scheme_Object** argv ) {
  return BOOLEAN( SOCKETP( argv[0] ));
}

static Scheme_Object* socket_open_p( int argc, Scheme_Object** argv ) {
  EXPECT_SOCKET( "socket-open?", 0 );
  return BOOLEAN( ((sock*)argv)->fd != INVALID );
}

static Scheme_Object* socket_close( int argc, Scheme_Object** argv ) {
  EXPECT_SOCKET( "socket-close", 0 );
  _socket_close( (sock*)argv[0] );
  return scheme_void;
}

static void _socket_shutdown( fd_t fd, int how ) {
  if (shutdown( fd, how ) < 0)
    scheme_raise( new_exn( "socket-shutdown", ERRNO ));
}

static Scheme_Object* socket_shutdown( int argc, Scheme_Object** argv ) {
  sock* s;
  int how; 
  
  EXPECT_SOCKET( "socket-shutdown", 0 );
  EXPECT_FIXNUM( "socket-shutdown", 1 );

  s = (sock*)argv[0];
  how = FIXNUM_VAL( argv[1] );
  
  _socket_shutdown( s->fd, how );
  return scheme_void;
}

static void inet_address_sockaddr( inet_address* ina, 
                                   struct sockaddr** sa, 
                                   socklen_t* salen ) {
  switch (ina->family) {
  case AF_INET:
    *sa = (struct sockaddr*)&ina->sa.sa_in;
    *salen = sizeof(struct sockaddr_in);
    break;
#ifdef HAVE_IPV6
  case AF_INET6:
    *sa = (struct sockaddr*)&ina->sa.sa_in6;
    *salen = sizeof(struct sockaddr_in6);
#endif
  }
}

// (<socket> where) => <bool>
static Scheme_Object* socket_connect( int argc, Scheme_Object** argv ) {
  sock* s;
  struct sockaddr* sa;
  socklen_t salen;
#ifdef UNIX
  struct sockaddr_un sa_un;
#endif
  
  EXPECT_SOCKET( "socket-connect", 0 );
  s = (sock*)argv[0];

  switch (s->domain) {
  case PF_INET: 
#ifdef HAVE_IPV6
  case PF_INET6:
#endif 
    EXPECT_INET_ADDRESS( "socket-connect", 1 );
    inet_address_sockaddr( (inet_address*)argv[1], &sa, &salen );
    break;
    
#ifdef UNIX
  case PF_UNIX: 
    EXPECT_PATH( "socket-connect", 1 );
    memset( &sa_un, 0, sizeof(sa_un) );
    sa_un.sun_family = AF_UNIX;
    memcpy( sa_un.sun_path, PATH_VAL( argv[1] ), 
            MIN(UNIX_PATH_MAX, PATH_LEN( argv[1] )));
    sa = (struct sockaddr*)&sa_un;
    salen = (socklen_t)sizeof(struct sockaddr_un);
    break;
#endif
  default:
    FAIL( "socket-connect: unsupported socket family" );
  }
  
 again:
  if (connect( s->fd, sa, salen ) < 0) {
    switch (ERRNO) {
    case EINTR: 
      goto again;
    case EINPROGRESS:
      return scheme_false; // async completion
    default:
      scheme_raise( new_exn( "socket-connect", ERRNO ));
    }
  } else return scheme_true; // immediate completion
}

// (<socket> where)
static Scheme_Object* socket_bind( int argc, Scheme_Object** argv ) {
  sock* s;
  struct sockaddr* sa;
  socklen_t salen;
#ifdef UNIX
  struct sockaddr_un sa_un;
#endif
  
  EXPECT_SOCKET( "socket-bind", 0 );
  s = (sock*)argv[0];

  switch (s->domain) {
  case PF_INET:
#ifdef HAVE_IPV6 
  case PF_INET6:
#endif 
    EXPECT_INET_ADDRESS( "socket-bind", 1 );
    inet_address_sockaddr( (inet_address*)argv[1], &sa, &salen );
    break;
    
#ifdef UNIX
  case PF_UNIX:
    EXPECT_PATH( "socket-bind", 1 );
    memset( &sa_un, 0, sizeof(sa_un) );
    sa_un.sun_family = AF_UNIX;
    memcpy( sa_un.sun_path, PATH_VAL( argv[1] ), 
            MIN(UNIX_PATH_MAX, PATH_LEN( argv[1] )));
    sa = (struct sockaddr*)&sa_un;
    salen = (socklen_t)sizeof(struct sockaddr_un);
    break;
#endif

  default:
    FAIL( "socket-bind: unsupported socket family" );
  }

  if (bind( s->fd, sa, salen ) < 0)
    scheme_raise( new_exn( "socket-bind", ERRNO ));
  return scheme_void;

}

// (<socket> <int>)
static Scheme_Object* socket_listen( int argc, Scheme_Object** argv ) {
  sock* s;
  EXPECT_SOCKET( "socket-listen", 0 );
  EXPECT_FIXNUM( "socket-listen", 1 );

  s = (sock*)argv[0];
  if (listen( s->fd, FIXNUM_VAL( argv[1] )) < 0)
    scheme_raise( new_exn( "socket-listen", ERRNO ));
  return scheme_void;
}

// (<socket>) => (<socket> where)
static Scheme_Object* socket_accept( int argc, Scheme_Object** argv ) {
  sock* s;
  fd_t fd;
  Scheme_Object* vals[2];
  Scheme_Object* rvals;
  struct sockaddr* sa;
  socklen_t salen;
  
  union {
    struct sockaddr_in sa_in;
    struct sockaddr_in sa_in6;
#ifdef UNIX
    struct sockaddr_un sa_un;
#endif
  } sap;
  
  // rvals is only refed for return
  MZ_GC_DECL_REG(2);
  MZ_GC_VAR_IN_REG(0, s);
  MZ_GC_ARRAY_VAR_IN_REG(1, vals, 2);

  EXPECT_SOCKET( "socket-accept", 0 );
  s = (sock*)argv[0];

  switch (s->domain) {
  case PF_INET:
    sa = (struct sockaddr*)&sap.sa_in;
    salen = (socklen_t)sizeof(struct sockaddr_in);
    break;
#ifdef HAVE_IPV6
  case PF_INET6:
    sa = (struct sockaddr*)&sap.sa_in6;
    salen = (socklen_t)sizeof(struct sockaddr_in6);
    break;
#endif
#ifdef UNIX
  case PF_UNIX: 
    sa = (struct sockaddr*)&sap.sa_un;
    salen = (socklen_t)sizeof(struct sockaddr_un);
    break;
#endif

  default:
    FAIL( "socket-accept: unsupported socket family" );
  }

  memset( sa, 0, (size_t)salen );
 again:
  if ((fd = accept( s->fd, sa, &salen )) == INVALID) {
    if (ERRNO == EINTR) goto again;
    else scheme_raise( new_exn( "socket-accept", ERRNO ));
  }

  memset( vals, 0, sizeof(vals) );
  MZ_GC_REG();        
  vals[0] = new_socket( fd, s->domain );
  switch (s->domain) {
  case PF_INET:
    vals[1] = new_inet_address( AF_INET, &sap.sa_in );
    break;
#ifdef HAVE_IPV6
  case PF_INET6:
    vals[1] = new_inet_address( AF_INET6, &sap.sa_in6 );
    break;
#endif
#ifdef UNIX
  case PF_UNIX: {
    long vlen;
    vlen = unix_path_len( sap.sa_un.sun_path ); // grrr, --xform
    vals[1] = PATH_SIZE( sap.sa_un.sun_path, vlen );
    } break;
#endif
  }
    
  rvals = scheme_values( 2, vals );
  MZ_GC_UNREG();
  return rvals;
}

// (<sock> <bytes> start end flags) => <int>
static Scheme_Object* socket_send( int argc, Scheme_Object** argv ) {
  sock* s;
  char* buf;
  size_t blen;
  int b, e, flags, olen;
  
  EXPECT_SOCKET( "socket-send", 0 );
  EXPECT_BYTES( "socket-send", 1 );
  EXPECT_FIXNUM( "socket-send", 2 );
  EXPECT_FIXNUM( "socket-send", 3 );
  EXPECT_FIXNUM( "socket-send", 4 );
  
  b = FIXNUM_VAL( argv[2] );
  e = FIXNUM_VAL( argv[3] );
  CHECK_RANGE( "socket-send", argv[1], b, e );
  
  s = (sock*)argv[0];
  buf = BYTES_VAL( argv[1] ) + b;
  blen = (size_t)(e - b);
  flags = FIXNUM_VAL( argv[4] );
  
 again:
  olen = send( s->fd, buf, blen, flags );
  if (olen < 0) {
    if (ERRNO == EINTR) goto again;
    else scheme_raise( new_exn( "socket-send", ERRNO ));
  }
  
  return FIXNUM( olen );
}

// (<sock> <bytes> start end flags where) => <int>
// wrapper has <sock> where ... argument order
static Scheme_Object* socket_sendto( int argc, Scheme_Object** argv ) {
  sock* s;
  char* buf;
  size_t blen;
  int flags, b, e, olen;
  struct sockaddr* sa;
  socklen_t salen;
#ifdef UNIX
  struct sockaddr_un sa_un;
#endif

  EXPECT_SOCKET( "socket-send", 0 );
  EXPECT_BYTES( "socket-send", 1 );
  EXPECT_FIXNUM( "socket-send", 2 );
  EXPECT_FIXNUM( "socket-send", 3 );
  EXPECT_FIXNUM( "socket-send", 4 );

  b = FIXNUM_VAL( argv[2] );
  e = FIXNUM_VAL( argv[3] );
  CHECK_RANGE( "socket-sendto", argv[1], b, e );
  
  s = (sock*)argv[0];
  buf = BYTES_VAL( argv[1] ) + b;
  blen = (size_t)(e - b);
  flags = FIXNUM_VAL( argv[4] );

  switch (s->domain) {
  case PF_INET:
#ifdef HAVE_IPV6 
  case PF_INET6:
#endif
    EXPECT_INET_ADDRESS( "socket-sendto", 5 );
    inet_address_sockaddr( (inet_address*)argv[5], &sa, &salen );
    break;
    
#ifdef UNIX
  case PF_UNIX: 
    EXPECT_PATH( "socket-sendto", 5 );
    memset( &sa_un, 0, sizeof(sa_un) );
    sa_un.sun_family = AF_UNIX;
    memcpy( sa_un.sun_path, PATH_VAL( argv[5] ), 
            MIN(UNIX_PATH_MAX, PATH_LEN( argv[5] )));
    sa = (struct sockaddr*)&sa_un;
    salen = (socklen_t)sizeof(struct sockaddr_un);
    break;
#endif
  default:
    FAIL( "socket-sendto: unsupported socket family" );

  }
      
 again:
  olen = sendto( s->fd, buf, blen, flags, sa, salen );
  if (olen < 0) {
    if (ERRNO == EINTR) goto again;
    else scheme_raise( new_exn( "socket-send", ERRNO ));
  }
  
  return FIXNUM( olen );
}


// (<sock> <bytes> start end flags) => <int>
// wrapper checks range
static Scheme_Object* socket_recv( int argc, Scheme_Object** argv ) {
  sock* s;
  char* buf;
  size_t blen;
  int flags, b, e, ilen;
  
  EXPECT_SOCKET( "socket-recv", 0 );
  EXPECT_MUTABLE_BYTES( "socket-recv", 1 );
  EXPECT_FIXNUM( "socket-recv", 2 );
  EXPECT_FIXNUM( "socket-recv", 3 );
  EXPECT_FIXNUM( "socket-recv", 4 );

  b = FIXNUM_VAL( argv[2] );
  e = FIXNUM_VAL( argv[3] );
  CHECK_RANGE( "socket-recv", argv[1], b, e );

  s = (sock*)argv[0];
  buf = BYTES_VAL( argv[1] ) + b;
  blen = (size_t)(e - b);
  flags = FIXNUM_VAL( argv[4] );
  
 again:
  ilen = recv( s->fd, buf, blen, flags );
  if (ilen < 0) {
    if (ERRNO == EINTR) goto again;
    else scheme_raise( new_exn( "socket-recv", ERRNO ));
  }
  
  return FIXNUM( ilen );
}

// (<sock> <bytes> start end flags) => (<int> where)
// wrapper has <sock> where ... argument order
static Scheme_Object* socket_recvfrom( int argc, Scheme_Object** argv ) {
  sock* s = NULL;
  char* buf;
  size_t blen;
  int flags, b, e, ilen;
  Scheme_Object* vals[2];
  Scheme_Object* rvals;
  struct sockaddr* sa;
  socklen_t salen;
  union {
    struct sockaddr_in sa_in;
    struct sockaddr_in6 sa_in6;
#ifdef UNIX
    struct sockaddr_un sa_un;
#endif
  } sap;
  
  // buf is an interior pointer in an argument, but it is not touched
  // in places where gc can occur, so there is no registration
  // rvals is only refed on return
  MZ_GC_DECL_REG(2);
  MZ_GC_VAR_IN_REG(0, s);
  MZ_GC_ARRAY_VAR_IN_REG(1, vals, 2);
  
  EXPECT_SOCKET( "socket-recvfrom", 0 );
  EXPECT_MUTABLE_BYTES( "socket-recvfrom", 1 );
  EXPECT_FIXNUM( "socket-recvfrom", 2 );
  EXPECT_FIXNUM( "socket-recvfrom", 3 );
  EXPECT_FIXNUM( "socket-recvfrom", 4 );

  b = FIXNUM_VAL( argv[2] );
  e = FIXNUM_VAL( argv[3] );
  CHECK_RANGE( "socket-recvfrom", argv[1], b, e );

  s = (sock*)argv[0];
  buf = BYTES_VAL( argv[1] ) + b;
  blen = (size_t)(e - b);
  flags = FIXNUM_VAL( argv[4] );

  switch (s->domain) {
  case PF_INET:
    sa = (struct sockaddr*)&sap.sa_in;
    salen = (socklen_t)sizeof(struct sockaddr_in);
    break;
#ifdef HAVE_IPV6
  case PF_INET6:
    sa = (struct sockaddr*)&sap.sa_in6;
    salen = (socklen_t)sizeof(struct sockaddr_in6);
    break;
#endif
#ifdef UNIX
  case PF_UNIX:
    sa = (struct sockaddr*)&sap.sa_un;
    salen = (socklen_t)sizeof(struct sockaddr_un);
    break;
#endif
  default:
    FAIL( "socket-recvfrom: unsupported socket family" );
  }

  memset( sa, 0, salen );
  
 again:
  ilen = recvfrom( s->fd, buf, blen, flags, sa, &salen );
  if (ilen < 0) {
    if (ERRNO == EINTR) goto again;
    else scheme_raise( new_exn( "socket-recvfrom", ERRNO ));
  }

  memset( vals, 0, sizeof(vals) );
  MZ_GC_REG();

  vals[0] = FIXNUM( ilen );
  switch (s->domain) {
  case PF_INET:
    vals[1] = new_inet_address( AF_INET, &sap.sa_in );
    break;
#ifdef HAVE_IPV6
  case PF_INET6:
    vals[1] = new_inet_address( AF_INET6, &sap.sa_in6 );
    break;
#endif
#ifdef UNIX
  case PF_UNIX:
    vals[1] = PATH_SIZE( sap.sa_un.sun_path, 
                         unix_path_len( sap.sa_un.sun_path ));
    break;
#endif
  }
  
  rvals = scheme_values( 2, vals );
  MZ_GC_UNREG();
  return rvals;
}

#define INIT_MSGHDR() \
  s = (sock*)argv[0]; \
  memset( &hdr, 0, sizeof(struct msghdr) ); \
  if (BYTESP(argv[1])) { \
    hdr.msg_name = BYTES_VAL(argv[1]); \
    hdr.msg_namelen = BYTES_LEN(argv[1]); \
  } \
  if (BYTESP(argv[2])) { \
    iov.iov_base = BYTES_VAL(argv[2]); \
    iov.iov_len = BYTES_LEN(argv[2]); \
    hdr.msg_iov = &iov; \
    hdr.msg_iovlen = 1; \
  } \
  if (BYTESP(argv[3])) { \
    hdr.msg_control = BYTES_VAL(argv[3]); \
    hdr.msg_controllen = BYTES_LEN(argv[3]); \
  } \
  flags = FIXNUM_VAL( argv[4] )

// <sock> <bytes-or-false> <bytes-or-false> <bytes-or-false> <int> => <int>
// wrapper checks vector types
static Scheme_Object* socket_sendmsg( int argc, Scheme_Object** argv ) {
#ifdef UNIX
  struct msghdr hdr;
  struct iovec iov;
  sock* s;
  int flags;
  int r;

  EXPECT_SOCKET( "socket-sendmsg", 0 );
  EXPECT_BYTES_OR_FALSE( "socket-sendmsg", 1 );
  EXPECT_BYTES_OR_FALSE( "socket-sendmsg", 2 );
  EXPECT_BYTES_OR_FALSE( "socket-sendmsg", 3 );
  EXPECT_FIXNUM( "socket-sendmsg", 4 );
  
  INIT_MSGHDR();
  
 again:
  if ((r = sendmsg( s->fd, &hdr, flags)) < 0) {
    if (ERRNO == EINTR) goto again;
    else scheme_raise( new_exn( "socket-sendmsg", ERRNO ));
  }
  
  return FIXNUM( r );

#else
  FAIL( "socket-sendmsg: unavalable function" );
#endif
}

// <sock> #3(<bytes-or-false>) <int> => (<int> <int> <int> <int>)
BEGIN_ALLOW_XFORM
static Scheme_Object* socket_recvmsg( int argc, Scheme_Object** argv ) {
#ifdef UNIX
  struct msghdr hdr;
  struct iovec iov;
  sock* s;
  int flags;
  int r;
  Scheme_Object* vals[4];

  EXPECT_SOCKET( "socket-revmsg", 0 );
  EXPECT_MUTABLE_BYTES_OR_FALSE( "socket-revmsg", 1 );
  EXPECT_MUTABLE_BYTES_OR_FALSE( "socket-revmsg", 2 );
  EXPECT_MUTABLE_BYTES_OR_FALSE( "socket-revmsg", 3 );
  EXPECT_FIXNUM( "socket-revmsg", 4 );

  INIT_MSGHDR();

 again:
  if ((r = recvmsg( s->fd, &hdr, flags)) < 0) {
    if (ERRNO == EINTR) goto again;
    else scheme_raise( new_exn( "socket-recvmsg", ERRNO ));
  }
  
  vals[0] = FIXNUM( r );
  if (hdr.msg_name) {
    vals[1] = FIXNUM( hdr.msg_namelen );
  } else vals[1] = scheme_false;
  if (hdr.msg_control) {
    vals[2] = FIXNUM( hdr.msg_controllen );
  } else vals[2] = scheme_false;
  vals[3] = FIXNUM( hdr.msg_flags );
  
  return scheme_values( 4, vals );
#else
  FAIL( "socket-recvmsg: unavalable function" );
#endif
}
END_ALLOW_XFORM

#ifdef UNIX
typedef int (*namefun_t)(int, struct sockaddr*, socklen_t*);
#else
// fucking hell
typedef int (PASCAL *namefun_t)(int, struct sockaddr*, socklen_t*);
#endif

static Scheme_Object* _getname( sock* s, namefun_t f, const char* fname ) {
  struct sockaddr* sa;
  socklen_t salen;
  union {
    struct sockaddr_in sa_in;
    struct sockaddr_in6 sa_in6;
#ifdef UNIX
    struct sockaddr_un sa_un;
#endif
  } sap;

  switch (s->domain) {
  case PF_INET: 
    sa = (struct sockaddr*)&sap.sa_in;
    salen = sizeof(struct sockaddr_in);
    break;
#ifdef HAVE_IPV6
  case PF_INET6:
    sa = (struct sockaddr*)&sap.sa_in6;
    salen = sizeof(struct sockaddr_in6);
    break;
#endif
#ifdef UNIX
  case PF_UNIX:
    memset( &sap.sa_un, 0, sizeof(struct sockaddr_un) );
    sa = (struct sockaddr*)&sap.sa_un;
    salen = sizeof(struct sockaddr_un);
    break;
#endif
  default:
    FAIL2( fname, "unsupported socket family" );
  }
  
  if (f( s->fd, sa, &salen ) < 0)
    scheme_raise( new_exn( fname, ERRNO ));
  
  switch (s->domain) {
  case PF_INET: 
    return new_inet_address( AF_INET, &sap.sa_in );
#ifdef HAVE_IPV6
  case PF_INET6: 
    return new_inet_address( AF_INET6, &sap.sa_in6 );
#endif
#ifdef UNIX
  case PF_UNIX:
    return PATH_SIZE( sap.sa_un.sun_path, unix_path_len( sap.sa_un.sun_path ));
#endif
  }
}

static Scheme_Object* socket_getsockname( int argc, Scheme_Object** argv ) {
  EXPECT_SOCKET( "socket-getsockname", 0 );
  return _getname( (sock*)argv[0], getsockname, "socket-getsockname" );
}

static Scheme_Object* socket_getpeername( int argc, Scheme_Object** argv ) {
  EXPECT_SOCKET( "socket-getpeername", 0 );
  return _getname( (sock*)argv[0], getpeername, "socket-getpeername" );
}

static Scheme_Object* socket_getsockopt_raw( int argc, Scheme_Object** argv ) {
  sock* s;
  socklen_t vlen;

  EXPECT_SOCKET( "socket-getsockopt/bytes", 0 );
  EXPECT_FIXNUM( "socket-getsockopt/bytes", 1 );
  EXPECT_FIXNUM( "socket-getsockopt/bytes", 2 );
  EXPECT_MUTABLE_BYTES( "socket-getsockopt/bytes", 3 );

  s = (sock*)argv[0];
  vlen = (socklen_t)BYTES_LEN( argv[3] );
  if (getsockopt( s->fd, FIXNUM_VAL(argv[1]), FIXNUM_VAL(argv[2]), 
                  BYTES_VAL( argv[3] ), &vlen ) < 0)
    scheme_raise( new_exn( "socket-getsockopt/bytes", ERRNO ));
  else return FIXNUM(vlen);
}

static Scheme_Object* socket_setsockopt_raw( int argc, Scheme_Object** argv ) {
  sock* s;

  EXPECT_SOCKET( "socket-setsockopt/bytes", 0 );
  EXPECT_FIXNUM( "socket-setsockopt/bytes", 1 );
  EXPECT_FIXNUM( "socket-setsockopt/bytes", 2 );
  EXPECT_BYTES( "socket-setsockopt/bytes", 3 );
  
  s = (sock*)argv[0];
  if (setsockopt( s->fd, FIXNUM_VAL(argv[1]), FIXNUM_VAL(argv[2]), 
                  BYTES_VAL( argv[3] ), (socklen_t)BYTES_LEN( argv[3] )) < 0)
    scheme_raise( new_exn( "socket-setsockopt/bytes", ERRNO ));
  else return scheme_void;
}

#include "sockopt.rules.h"

static Scheme_Object* socket_getsockopt( int argc, Scheme_Object** argv ) {
  sock* s;
  int level;
  int opt;
  socklen_t vlen;

  EXPECT_SOCKET( "socket-getsockopt", 0 );
  EXPECT_FIXNUM( "socket-getsockopt", 1 );
  EXPECT_FIXNUM( "socket-getsockopt", 2 );
  
  s = (sock*)argv[0];
  level = FIXNUM_VAL( argv[1] );
  opt = FIXNUM_VAL( argv[2] );
  
  switch (level) {
#include "sockopt.get"
  default:
    FAIL( "socket-getsockopt: unknown level" );
  }
}

static Scheme_Object* socket_setsockopt( int argc, Scheme_Object** argv ) {
  sock* s;
  int level;
  int opt;
  socklen_t vlen;

  EXPECT_SOCKET( "socket-getsockopt", 0 );
  EXPECT_FIXNUM( "socket-getsockopt", 1 );
  EXPECT_FIXNUM( "socket-getsockopt", 2 );
  
  s = (sock*)argv[0];
  level = FIXNUM_VAL( argv[1] );
  opt = FIXNUM_VAL( argv[2] );
  
  switch (level) {
#include "sockopt.set"
  default:
    FAIL( "socket-setsockopt: unknown level" );
  }
}

static void print_sock( Scheme_Object* v, int dis, 
                        Scheme_Print_Params* pp ) {
  char buf[64];
  int len;
  sock* s = (sock*)v;

  len = snprintf( buf, sizeof(buf), "#<socket %p %d>", s, s->fd );
  scheme_print_bytes( pp, buf, 0, len );
}


// sock_evt
static Scheme_Object* new_socket_evt( sock* s, enum evt_t t ) {
  sock_evt* evt;
  evt = (sock_evt*)scheme_malloc_tagged( sizeof(sock_evt));
  evt->tag.type = sock_evt_tag;
  evt->s = s;
  evt->t = t;
  return (Scheme_Object*)evt;
}

static Scheme_Object* make_socket_evt( int argc, Scheme_Object** argv ) {
  sock* s;
  int t;
  EXPECT_SOCKET( "socket-evt", 0 );
  EXPECT_FIXNUM( "socket-evt", 1 );
  s = (sock*)argv[0];
  t = FIXNUM_VAL( argv[1] );
  if (s->fd == INVALID) {
    FAIL( "socket-evt: bad socket" );
  }
  if (t & (evt_read | evt_write | evt_except)) {
    return new_socket_evt( s, (enum evt_t)t );
  } else {
    FAIL( "socket-evt: bad event type" );
  }
}

static int sock_evt_ready( Scheme_Object* data ) {
  sock_evt* evt = (sock_evt*)data;
  if (evt->s->fd == INVALID) {
    return -1;
  } else {
    static struct timeval tvpoll = {0, 0};
    fd_set rfds, wfds, efds;
    int r;
    
    FD_ZERO( &rfds );
    FD_ZERO( &wfds );
    FD_ZERO( &efds );
    if (evt->t & evt_read) FD_SET( evt->s->fd, &rfds );
    if (evt->t & evt_write) FD_SET( evt->s->fd, &wfds );
    if (evt->t & evt_except) FD_SET( evt->s->fd, &efds );
    
  again:
    r = select( evt->s->fd + 1, &rfds, &wfds, &efds, &tvpoll );
    if ((r < 0) && (ERRNO == EINTR)) goto again;
    return r;
  }

}

static void sock_evt_setfds( Scheme_Object* data, void* fds ) {
  sock_evt* evt;
  evt = (sock_evt*)data;
  if (evt->s->fd != INVALID) {
    if (evt->t & evt_read) MZ_FD_SET( evt->s->fd, MZ_GET_FDSET( fds, 0 ));
    if (evt->t & evt_write) MZ_FD_SET( evt->s->fd, MZ_GET_FDSET( fds, 1 ));
    if (evt->t & evt_except) MZ_FD_SET( evt->s->fd, MZ_GET_FDSET( fds, 2 ));
  }
}

// 3m
#ifdef MZ_PRECISE_GC
static int inet_address_SIZE( void* p ) {
  return gcBYTES_TO_WORDS(sizeof(inet_address));
}

static int inet_address_MARK( void* p ) {
  return gcBYTES_TO_WORDS(sizeof(inet_address));
}

static int inet_address_FIXUP( void* p ) {
  return gcBYTES_TO_WORDS(sizeof(inet_address));
}

static int sock_SIZE( void* p ) {
  sock* s = (sock*)p;
  return gcBYTES_TO_WORDS(sizeof(sock));
}

static int sock_MARK( void* p ) {
  sock* s = (sock*)p;
  if (s->fd != INVALID)
    gcMARK( s->custodian );
  return gcBYTES_TO_WORDS(sizeof(sock));
}

static int sock_FIXUP( void* p ) {
  sock* s = (sock*)p;
  if (s->fd != INVALID)
    gcFIXUP( s->custodian );
  return gcBYTES_TO_WORDS(sizeof(sock));
}

static int sock_evt_SIZE( void* p ) {
  sock_evt* s = (sock_evt*)p;
  return gcBYTES_TO_WORDS(sizeof(sock_evt));
}

static int sock_evt_MARK( void* p ) {
  sock_evt* s = (sock_evt*)p;
  gcMARK( s->s );
  return gcBYTES_TO_WORDS(sizeof(sock_evt));
}

static int sock_evt_FIXUP( void* p ) {
  sock_evt* s = (sock_evt*)p;
  gcFIXUP( s->s );
  return gcBYTES_TO_WORDS(sizeof(sock_evt));
}
#endif

// module
#ifdef UNIX
static void unix_init() {
  signal( SIGPIPE, SIG_IGN );
}
#else
static void winsock_exit() {
  WSACleanUp();
}
static void winsock_init() {
  WSADATA data;
  if (WSAStartup( MAKEWORD(2, 2), &data ) < 0)
    scheme_raise_exn( MZEXN_FAIL, "Winsock: initialization failure (%d)", 
                      ERRNO );
  atexit( winsock_exit );
}

#endif

BEGIN_ALLOW_XFORM
Scheme_Object* scheme_reload( Scheme_Env* env ) {
  Scheme_Env* module;
  module = scheme_primitive_module( SYMBOL( "_socket" ), env );
  
  EXPORT_PROC( "make-exn:socket", make_exn, 2 );
  EXPORT_PROC( "exn:socket-errno", exn_errno, 1 );
  EXPORT_PROC( "exn:socket?", exn_p, 1 );

  EXPORT_VPROC( "make-inet-address", make_inet_address, 3 );
  EXPORT_PROC( "inet-address?", inet_address_p, 1 );
  EXPORT_VPROC( "inet-address=?", inet_address_equalp, 2 );
  EXPORT_PROC( "inet-address-family", inet_address_family, 1 );
  EXPORT_PROC( "inet-address-host", inet_address_host, 1 );
  EXPORT_PROC( "inet-address-port", inet_address_port, 1 );

  EXPORT_PROC( "inet-address->vector", inet_address_to_vec, 1 );
  EXPORT_PROC( "vector->inet-address", vec_to_inet_address, 1 );
  EXPORT_PROC( "pack-address", pack_address, 1 );
  EXPORT_PROC( "unpack-address", unpack_address, 1 );
  
  EXPORT_PROC( "make-socket", make_socket, 3 );
  EXPORT_PROC( "socket?", socket_p, 1 );
  EXPORT_PROC( "socket-open?", socket_open_p, 1 );
  EXPORT_PROC( "socket-close", socket_close, 1 );
  EXPORT_PROC( "socket-shutdown", socket_shutdown, 2 );
  EXPORT_PROC( "socket-connect", socket_connect, 2 );
  EXPORT_PROC( "socket-bind", socket_bind, 2 );
  EXPORT_PROC( "socket-listen", socket_listen, 2 );
  EXPORT_PROC( "socket-accept", socket_accept, 1 );
  EXPORT_PROC( "socket-send", socket_send, 5 );
  EXPORT_PROC( "socket-recv", socket_recv, 5 );
  EXPORT_PROC( "socket-sendto", socket_sendto, 6 );
  EXPORT_PROC( "socket-recvfrom", socket_recvfrom, 5 );
  EXPORT_PROC( "socket-sendmsg", socket_sendmsg, 5 );
  EXPORT_PROC( "socket-recvmsg", socket_recvmsg, 5 );
  EXPORT_PROC( "socket-getsockname", socket_getsockname, 1 );
  EXPORT_PROC( "socket-getpeername", socket_getpeername, 1 );
  EXPORT_PROC( "socket-getsockopt", socket_getsockopt, 3 );
  EXPORT_PROC( "socket-setsockopt", socket_setsockopt, 4 );
  EXPORT_PROC( "socket-getsockopt/bytes", socket_getsockopt_raw, 4 );
  EXPORT_PROC( "socket-setsockopt/bytes", socket_setsockopt_raw, 4 );

  EXPORT_PROC( "socket-evt", make_socket_evt, 2 );
  EXPORT_VAL( "socket-evt:read", FIXNUM(evt_read) );
  EXPORT_VAL( "socket-evt:write", FIXNUM(evt_write) );
  EXPORT_VAL( "socket-evt:except", FIXNUM(evt_except) );
  
  scheme_finish_primitive_module( module );
  return scheme_void;
}

Scheme_Object* scheme_initialize( Scheme_Env* env ) {
#ifdef UNIX
  unix_init();
#else
  winsock_init();
#endif

  // types
  inet_address_tag = scheme_make_type( "<inet-address>" );
  sock_tag = scheme_make_type( "<socket>" );
  sock_evt_tag = scheme_make_type( "<socket-evt>" );
  REGISTER_GC( inet_address_tag, 
               inet_address_SIZE, inet_address_MARK, inet_address_FIXUP, 
               1, 1 );
  REGISTER_GC( sock_tag,
               sock_SIZE, sock_MARK, sock_FIXUP,
               1, 0 );
  REGISTER_GC( sock_evt_tag,
               sock_evt_SIZE, sock_evt_MARK, sock_evt_FIXUP,
               1, 0 );
  REGISTER_STATIC(exn_type);
  exn_type = 
    scheme_make_struct_type( SYMBOL( "exn:fail:socket" ),
                             scheme_lookup_global( SYMBOL( "struct:exn:fail:network" ), env ),
                             NULL, 1, 0, NULL, NULL, NULL );
  
  scheme_add_evt( sock_evt_tag, sock_evt_ready, sock_evt_setfds,
                  NULL, 0 );
  scheme_set_type_printer( inet_address_tag, print_inet_address );
  scheme_set_type_printer( sock_tag, print_sock );
#ifdef HAVE_TYPE_EQUALITY
  scheme_set_type_equality( inet_address_tag, 
                            inet_address_equal, 
                            inet_address_hash1, inet_address_hash2 );
#endif

  return scheme_reload( env );
}

Scheme_Object* scheme_module_name() {
  return SYMBOL( "_socket" );
}

END_ALLOW_XFORM
END_XFORM