/*---------------------------------------------------------------------------*
  C MODULE  cf_socket_p.c

  Copyright (c) 2003-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
‚    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*/

#include "cf_socket_p.h"

#include <sys/time.h>
#include <unistd.h>
#include <string.h>
#include <errno.h>
#include <stdio.h>

#define FAILWITH(S)            (failwith("Cf_socket." S))
#define INVALID_ARGUMENT(S)    (invalid_argument("Cf_socket." S))

static int cf_socket_domain_compare(value v1, value v2)
{
    CAMLparam2(v1, v2);
    int pf1, pf2;
        
    pf1 = Cf_socket_domain_val(v1)->d_domain;
    pf2 = Cf_socket_domain_val(v2)->d_domain;
    if (pf1 == pf2) {
        pf1 = Cf_socket_domain_val(v1)->d_family;
        pf2 = Cf_socket_domain_val(v2)->d_family;
    }
    
    CAMLreturn(pf2 - pf1);
}

static long cf_socket_domain_hash(value v)
{
    CAMLparam1(v);
    CAMLreturn((long) Cf_socket_domain_val(v)->d_domain);
}

static struct custom_operations cf_socket_domain_op = {
    "org.conjury.ocnae.cf.socket_domain",
    custom_finalize_default,
    cf_socket_domain_compare,
    cf_socket_domain_hash,
    custom_serialize_default,
    custom_deserialize_default
};

static int cf_socket_compare(value v1, value v2)
{
    CAMLparam2(v1, v2);
    CAMLreturn(Cf_socket_val(v2)->s_fd - Cf_socket_val(v1)->s_fd);
}

static long cf_socket_hash(value v)
{
    CAMLparam1(v);    
    CAMLreturn((long) Cf_socket_val(v)->s_fd);
}

static struct custom_operations cf_socket_op = {
    "org.conjury.ocnae.cf.socket",
    custom_finalize_default,
    cf_socket_compare,
    cf_socket_hash,
    custom_serialize_default,
    custom_deserialize_default
};

value cf_socket_domain_alloc(const Cf_socket_domain_t* ptr)
{
    value sVal;
    
    sVal = alloc_custom(&cf_socket_domain_op, sizeof *ptr, 0, 1);
    memcpy(Cf_socket_domain_val(sVal), ptr, sizeof *ptr);
    return sVal;
}

value cf_socket_alloc
   (int fd, int socktype, int protocol, const Cf_socket_domain_t* domainPtr)
{
    value sVal;
    Cf_socket_t* sPtr;
    
    sVal = alloc_custom(&cf_socket_op, sizeof *sPtr, 0, 1);
    sPtr = Cf_socket_val(sVal);
    sPtr->s_fd = fd;
    sPtr->s_socktype = socktype;
    sPtr->s_protocol = protocol;
    sPtr->s_domain = *domainPtr;
    return sVal;
}

/*---
    external create:
        'af domain_t -> 'st socktype_t -> protocol_t -> ('st,'af) t =
        "cf_socket_create"
  ---*/
CAMLprim value cf_socket_create
   (value domainVal, value typeVal, value protocolVal)
{
    CAMLparam3(domainVal, typeVal, protocolVal);
    
    int type, protocol, fd;
    const Cf_socket_domain_t* domainPtr;
    
    domainPtr = Cf_socket_domain_val(domainVal);
    type = Nativeint_val(typeVal);
    protocol = Nativeint_val(protocolVal);
    
    fd = socket(domainPtr->d_domain, type, protocol);
    if (fd < 0) uerror("socket", Nothing);
    CAMLreturn(cf_socket_alloc(fd, type, protocol, domainPtr));
}

/*---
    external createpair:
        'af domain_t -> 'st socktype_t -> protocol_t ->
        (('st,'af) t as 'fd) * 'fd = "cf_socket_createpair"
  ---*/
CAMLprim value cf_socket_createpair
   (value domainVal, value typeVal, value protocolVal)
{
    CAMLparam3(domainVal, typeVal, protocolVal);
    CAMLlocal1(resultVal);
    CAMLlocalN(fdVal, 2);
    
    int type, protocol, fd[2];
    const Cf_socket_domain_t* domainPtr;

    domainPtr = Cf_socket_domain_val(domainVal);
    type = Nativeint_val(typeVal);
    protocol = Nativeint_val(protocolVal);
    
    if (socketpair(domainPtr->d_domain, type, protocol, fd))
        uerror("socketpair", Nothing);
    
    fdVal[0] = cf_socket_alloc(fd[0], type, protocol, domainPtr);
    fdVal[1] = cf_socket_alloc(fd[1], type, protocol, domainPtr);

    resultVal = alloc_small(2, 0);
    Store_field(resultVal, 0, fdVal[0]);
    Store_field(resultVal, 1, fdVal[1]);
    CAMLreturn(resultVal);
}

/*---
    external to_unix_file_descr:
        ('af,'st) t -> Unix.file_descr = "cf_socket_to_unix_file_descr"
  ---*/
CAMLprim value cf_socket_to_unix_file_descr(value sockVal)
{
    CAMLparam1(sockVal);
    CAMLreturn(Val_int(Cf_socket_val(sockVal)->s_fd));
}

/*---
external domain_of_sockaddr:
    'af sockaddr_t -> 'af domain_t = "cf_socket_domain_of_unit_sockaddr"
  ---*/
CAMLprim value cf_socket_domain_of_sockaddr(value sxVal)
{
    CAMLparam1(sxVal);
    
    const Cf_socket_sockaddrx_unit_t* sxPtr;
    
    sxPtr = Cf_socket_sockaddrx_unit_val(sxVal);
    CAMLreturn(copy_nativeint(sxPtr->sx_sockaddr.sa_family));
}

/*---
external dup: (('af,'st) t as 'fd) -> 'fd = "cf_socket_dup"
  ---*/
CAMLprim value cf_socket_dup(value sockVal)
{
    CAMLparam1(sockVal);
    CAMLlocal1(resultVal);
    
    const Cf_socket_t* sockPtr = Cf_socket_val(sockVal);
    int fd;
    
    fd = dup(sockPtr->s_fd);
    if (fd == -1) uerror("dup", Nothing);
    
    resultVal = cf_socket_alloc
        (fd, sockPtr->s_socktype, sockPtr->s_protocol, &sockPtr->s_domain);
    CAMLreturn(resultVal);
}

/*---
external dup2: (('af,'st) t as 'fd) -> 'fd -> unit = "cf_socket_dup2"
  ---*/
CAMLprim void cf_socket_dup2(value sock1Val, value sock2Val)
{
    CAMLparam2(sock1Val, sock2Val);
    
    const Cf_socket_t* sock1Ptr = Cf_socket_val(sock1Val);
    const Cf_socket_t* sock2Ptr = Cf_socket_val(sock2Val);
    
    if (dup2(sock1Ptr->s_fd, sock2Ptr->s_fd) == -1) uerror("dup", Nothing);    
    CAMLreturn0;
}

static const int cf_socket_msg_flags_array[] = {
    MSG_OOB, MSG_PEEK, MSG_DONTROUTE, MSG_OOB, MSG_EOR, MSG_TRUNC,
    MSG_CTRUNC, MSG_WAITALL, MSG_DONTWAIT
};

#define Cf_socket_msg_flags_array_size \
    (sizeof cf_socket_msg_flags_array / sizeof cf_socket_msg_flags_array[0])

int cf_socket_msg_flags_to_int(value flagsVal)
{
    int flags = 0;
    int i;
    
    for (i = 0; i < Cf_socket_msg_flags_array_size; ++i)
        if (Field(flagsVal, i) != Val_false)
            flags |= cf_socket_msg_flags_array[i];
    
    return flags;
}

value cf_socket_msg_flags_of_int(int flags)
{
    CAMLparam0();
    CAMLlocal1(flagsVal);
    int i;
    
    flagsVal = alloc_small(Cf_socket_msg_flags_array_size, 0);
    for (i = 0; i < Cf_socket_msg_flags_array_size; ++i)
        Store_field(flagsVal, i,
            (flags & cf_socket_msg_flags_array[i]) ? Val_true : Val_false);
    
    CAMLreturn(flagsVal);
}

/*---
    external getsockname:
        ('af,'st) t -> 'af sockaddr_t = "cf_socket_getsockname"
  ---*/
CAMLprim value cf_socket_getsockname(value sockVal)
{
    CAMLparam1(sockVal);
    CAMLlocal1(sxVal);

    const Cf_socket_t* sockPtr;
    struct sockaddr_storage ss;
    struct sockaddr* saPtr;
    socklen_t addrLen;
    int v;
    
    sockPtr = Cf_socket_val(sockVal);
    saPtr = (struct sockaddr*) &ss;
    addrLen = sizeof ss;
    v = getsockname(sockPtr->s_fd, saPtr, &addrLen);
    if (v == -1) uerror("getsockname", Nothing);
        
    sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen);
    CAMLreturn(sxVal);
}

/*---
    external getpeername:
        ('af,'st) t -> 'af sockaddr_t = "cf_socket_getpeername"
  ---*/
CAMLprim value cf_socket_getpeername(value sockVal)
{
    CAMLparam1(sockVal);
    CAMLlocal1(sxVal);

    const Cf_socket_t* sockPtr;
    struct sockaddr_storage ss;
    struct sockaddr* saPtr;
    socklen_t addrLen;
    int v;
    
    sockPtr = Cf_socket_val(sockVal);
    saPtr = (struct sockaddr*) &ss;
    addrLen = sizeof ss;
    v = getpeername(sockPtr->s_fd, saPtr, &addrLen);
    if (v == -1) uerror("getpeername", Nothing);
        
    sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen);
    CAMLreturn(sxVal);
}

/*---
    external bind: ('af,'st) t -> 'af sockaddr_t -> unit = "cf_socket_bind"
  ---*/
CAMLprim void cf_socket_bind(value sockVal, value sxVal)
{
    CAMLparam2(sockVal, sxVal);
    
    const Cf_socket_t* sockPtr;
    const Cf_socket_sockaddrx_unit_t* sxPtr;
    
    sockPtr = Cf_socket_val(sockVal);
    sxPtr = Cf_socket_sockaddrx_unit_val(sxVal);
    if (bind(sockPtr->s_fd, &sxPtr->sx_sockaddr, sxPtr->sx_socklen))
        uerror("bind", Nothing);
    
    CAMLreturn0;
}

/*---
    external connect:
        ('af,'st) t -> 'af sockaddr_t -> unit = "cf_socket_connect"
  ---*/
CAMLprim void cf_socket_connect(value sockVal, value sxVal)
{
    CAMLparam2(sockVal, sxVal);
    
    const Cf_socket_t* sockPtr;
    const Cf_socket_sockaddrx_unit_t* sxPtr;
    int result, error;
    
    sockPtr = Cf_socket_val(sockVal);
    sxPtr = Cf_socket_sockaddrx_unit_val(sxVal);
    
    enter_blocking_section();
    result = connect(sockPtr->s_fd, &sxPtr->sx_sockaddr, sxPtr->sx_socklen);

    error = errno;

#ifdef __APPLE__
    /* Mac OS X does not return the error in errno on non-blocking sockets */
    if (result && error == EINVAL) {
        socklen_t optlen = sizeof error;
        getsockopt(sockPtr->s_fd, SOL_SOCKET, SO_ERROR, &error, &optlen);
    }
#endif

    leave_blocking_section();
    
    if (result) unix_error(error, "connect", Nothing);
    CAMLreturn0;
}

/*---
    external listen:
        ('af, ([< `SOCK_STREAM ] as 'st)) t -> int -> unit =
        "cf_socket_listen"
  ---*/
CAMLprim void cf_socket_listen(value sockVal, value backlogVal)
{
    CAMLparam2(sockVal, backlogVal);
    
    const Cf_socket_t* sockPtr;
    int backlog;
    
    sockPtr = Cf_socket_val(sockVal);
    backlog = Int_val(backlogVal);
    if (listen(sockPtr->s_fd, backlog)) uerror("listen", Nothing);
    
    CAMLreturn0;
}

/*---
external accept:
    ('af, ([< `SOCK_STREAM ] as 'st)) t -> ('af, 'st) t * 'af sockaddr_t =
    "cf_socket_accept"
  ---*/
CAMLprim value cf_socket_accept(value sockVal)
{
    CAMLparam1(sockVal);
    CAMLlocal3(newSockVal, sxVal, resultVal);

    const Cf_socket_t* sockPtr;
    struct sockaddr_storage ss;
    struct sockaddr* saPtr;
    socklen_t addrLen;
    int newFd, error;
    
    sockPtr = Cf_socket_val(sockVal);
    saPtr = (struct sockaddr*) &ss;
    addrLen = sizeof ss;
    
    enter_blocking_section();
    newFd = accept(sockPtr->s_fd, saPtr, &addrLen);
    error = errno;
    leave_blocking_section();
    
    if (newFd == -1) unix_error(error, "accept", Nothing);
    
    sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen);

    newSockVal = cf_socket_alloc
       (newFd, sockPtr->s_socktype, sockPtr->s_protocol, &sockPtr->s_domain);
    
    resultVal = alloc_small(2, 0);
    Store_field(resultVal, 0, newSockVal);
    Store_field(resultVal, 1, sxVal);
    
    CAMLreturn(resultVal);
}

/*---
external send:
    ('af, 'st) t -> string -> int -> int -> msg_flags_t -> int =
    "cf_socket_send"
  ---*/
CAMLprim value cf_socket_send
   (value sockVal, value dataVal, value posVal, value lenVal,
    value flagsVal)
{
    CAMLparam5(sockVal, dataVal, posVal, lenVal, flagsVal);
    
    const Cf_socket_t* sockPtr;
    const char* dataPtr;
    int fd, pos, len, flags, result, error;

    sockPtr = Cf_socket_val(sockVal);
    dataPtr = String_val(dataVal);
    pos = Int_val(posVal);
    len = Int_val(lenVal);
    flags = cf_socket_msg_flags_to_int(flagsVal);
    
    enter_blocking_section();
    result = send(sockPtr->s_fd, dataPtr + pos, len, flags);
    error = errno;
    leave_blocking_section();
    
    if (result < 0) unix_error(error, "send", Nothing);
    CAMLreturn(Val_int(result));
}

/*---
external sendto:
    ('af, ([< `SOCK_DGRAM ] as 'st)) t -> string -> int -> int ->
    msg_flags_t -> int = "cf_socket_sendto_bytecode"
    "cf_socket_sendto_native"
  ---*/
CAMLprim value cf_socket_sendto_native
   (value sockVal, value dataVal, value posVal, value lenVal,
    value flagsVal, value sxVal)
{
    CAMLparam5(sockVal, dataVal, posVal, lenVal, flagsVal);
    CAMLxparam1(sxVal);
    
    const Cf_socket_t* sockPtr;
    const char* dataPtr;
    int fd, pos, len, flags, result, error;
    const Cf_socket_sockaddrx_unit_t* sxPtr;
    
    sockPtr = Cf_socket_val(sockVal);
    dataPtr = String_val(dataVal);
    pos = Int_val(posVal);
    len = Int_val(lenVal);
    flags = cf_socket_msg_flags_to_int(flagsVal);
    sxPtr = Cf_socket_sockaddrx_unit_val(sxVal);
    
    enter_blocking_section();
    result = sendto(sockPtr->s_fd, dataPtr + pos, len, flags,
        &sxPtr->sx_sockaddr, sxPtr->sx_socklen);
    error = errno;
    leave_blocking_section();
    
    if (result < 0) unix_error(error, "sendto", Nothing);
    CAMLreturn(Val_int(result));
}

CAMLprim value cf_socket_sendto_bytecode(value * argv, int argn)
{
    return cf_socket_sendto_native
       (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
}

/*---
external recv:
    ('af, 'st) t -> string -> int -> int -> msg_flags_t -> int =
    "cf_socket_recv"
  ---*/
CAMLprim value cf_socket_recv
   (value sockVal, value dataVal, value posVal, value lenVal,
    value flagsVal)
{
    CAMLparam5(sockVal, dataVal, posVal, lenVal, flagsVal);
    
    const Cf_socket_t* sockPtr;
    char* dataPtr;
    int fd, pos, len, flags, result, error;

    sockPtr = Cf_socket_val(sockVal);
    dataPtr = String_val(dataVal);
    pos = Int_val(posVal);
    len = Int_val(lenVal);
    flags = cf_socket_msg_flags_to_int(flagsVal);
    
    enter_blocking_section();
    result = recv(sockPtr->s_fd, dataPtr + pos, len, flags);
    error = errno;
    leave_blocking_section();
    
    if (result < 0) unix_error(error, "recv", Nothing);
    CAMLreturn(Val_int(result));
}

/*---
external recvfrom:
    ('af, ([< `SOCK_DGRAM ] as 'st)) t -> string -> int -> int ->
    msg_flags_t -> int = "cf_socket_recvfrom"
  ---*/
CAMLprim value cf_socket_recvfrom
   (value sockVal, value dataVal, value posVal, value lenVal,
    value flagsVal)
{
    CAMLparam5(sockVal, dataVal, posVal, lenVal, flagsVal);
    CAMLlocal2(sxVal, resultVal);
    
    const Cf_socket_t* sockPtr;
    char* dataPtr;
    int fd, pos, len, flags, result, error;
    struct sockaddr_storage ss;
    struct sockaddr* saPtr;
    socklen_t addrLen;
    
    sockPtr = Cf_socket_val(sockVal);
    dataPtr = String_val(dataVal);
    pos = Int_val(posVal);
    len = Int_val(lenVal);
    flags = cf_socket_msg_flags_to_int(flagsVal);
    saPtr = (struct sockaddr*) &ss;
    addrLen = sizeof ss;

    enter_blocking_section();
    result = recvfrom(sockPtr->s_fd, dataPtr + pos, len, flags, saPtr,
        &addrLen);
    error = errno;
    leave_blocking_section();
    
    if (result < 0) unix_error(error, "recvfrom", Nothing);
    
    sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen);

    resultVal = alloc_small(2, 0);
    Store_field(resultVal, 0, Val_int(result));
    Store_field(resultVal, 1, sxVal);
    
    CAMLreturn(resultVal);
}

static int cf_socket_option_compare(value v1, value v2)
{
    CAMLparam2(v1, v2);
    
    const Cf_socket_option_t** opt1PtrPtr;
    const Cf_socket_option_t** opt2PtrPtr;
    int n;
    
    opt1PtrPtr = Cf_socket_option_val(v1);
    opt2PtrPtr = Cf_socket_option_val(v2);
    n = (*opt2PtrPtr)->opt_level - (*opt1PtrPtr)->opt_level;
    if (n == 0) n = (*opt2PtrPtr)->opt_name - (*opt1PtrPtr)->opt_name;
    
    CAMLreturn(n);
}

static long cf_socket_option_hash(value v)
{
    CAMLparam1(v);
    
    long n;
    const Cf_socket_option_t** optPtrPtr;
    
    optPtrPtr = Cf_socket_option_val(v);
    n = (long) *optPtrPtr;
    
    CAMLreturn(Val_int(n));
}

static struct custom_operations cf_socket_option_op = {
    "org.conjury.ocnae.cf.socket_option",
    custom_finalize_default,
    cf_socket_option_compare,
    cf_socket_option_hash,
    custom_serialize_default,
    custom_deserialize_default
};


value cf_socket_option_alloc(const Cf_socket_option_t* ptr)
{
    value optVal;
    
    optVal = alloc_custom(&cf_socket_option_op, sizeof ptr, 0, 1);
    *Cf_socket_option_val(optVal) = ptr;
    return optVal;
}

void cf_socket_getsockopt_guard
   (const Cf_socket_option_context_t* contextPtr, void* optval,
    socklen_t* optlen)
{
    int result;
    
    result = getsockopt
       (contextPtr->xopt_fd, contextPtr->xopt_level, contextPtr->xopt_name,
        optval, optlen);
    if (result) uerror("getsockopt", Nothing);
}

void cf_socket_setsockopt_guard
   (const Cf_socket_option_context_t* contextPtr, const void* optval,
    socklen_t optlen)
{
    int result;
    
    result = setsockopt
       (contextPtr->xopt_fd, contextPtr->xopt_level, contextPtr->xopt_name,
        optval, optlen);
    if (result) uerror("setsockopt", Nothing);
}

value cf_socket_getsockopt_bool
   (const Cf_socket_option_context_t* contextPtr)
{
    int optval;
    socklen_t optlen;
    
    optval = 0;
    optlen = sizeof optval;
    cf_socket_getsockopt_guard(contextPtr, &optval, &optlen);
    return optval ? Val_true : Val_false;
}

void cf_socket_setsockopt_bool
   (const Cf_socket_option_context_t* contextPtr, value x)
{
    int optval;
    
    optval = Bool_val(x);
    cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval);
}

value cf_socket_getsockopt_int
   (const Cf_socket_option_context_t* contextPtr)
{
    int optval;
    socklen_t optlen;
    
    optval = 0;
    optlen = sizeof optval;
    cf_socket_getsockopt_guard(contextPtr, &optval, &optlen);
    return Val_int(optval);
}

void cf_socket_setsockopt_int
   (const Cf_socket_option_context_t* contextPtr, value x)
{
    int optval;
    
    optval = Int_val(x);
    cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval);
}

value cf_socket_getsockopt_linger
   (const Cf_socket_option_context_t* contextPtr)
{
    struct linger optval;
    socklen_t optlen;
    value result;
    
    memset(&optval, 0, sizeof optval);
    optlen = sizeof optval;
    cf_socket_getsockopt_guard(contextPtr, &optval, &optlen);
    
    if (optval.l_onoff) {
        result = alloc_small(1, 0);
        Store_field(result, 0, Val_int(optval.l_linger));
    }
    else
        result = Val_int(0);
    
    return result;
}

void cf_socket_setsockopt_linger
   (const Cf_socket_option_context_t* contextPtr, value x)
{
    struct linger optval;
    
    memset(&optval, 0, sizeof optval);
    optval.l_onoff = Is_block(x);
    if (optval.l_onoff) optval.l_linger = Int_val(Field(x, 0));
    cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval);
}

value cf_socket_getsockopt_timeout
   (const Cf_socket_option_context_t* contextPtr)
{
    struct timeval optval;
    socklen_t optlen;
    double dt;
    value result;
    
    memset(&optval, 0, sizeof optval);
    optlen = sizeof optval;
    cf_socket_getsockopt_guard(contextPtr, &optval, &optlen);
        
    dt = (double) optval.tv_sec + (double) optval.tv_usec / 1E6;
    return copy_double(dt);
}

void cf_socket_setsockopt_timeout
   (const Cf_socket_option_context_t* contextPtr, value x)
{
    struct timeval optval;
    double dt;
    
    dt = Double_val(x);
    optval.tv_sec = (int) dt;
    optval.tv_usec = (int)(1E6 * (dt - optval.tv_sec));
    
    cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval);
}

value cf_socket_getsockopt_error
   (const Cf_socket_option_context_t* contextPtr)
{
    int optval;
    socklen_t optlen;
    
    memset(&optval, 0, sizeof optval);
    optlen = sizeof optval;
    cf_socket_getsockopt_guard(contextPtr, &optval, &optlen);

    if (optval) unix_error(optval, "getsockopt", Nothing);
    return Val_unit;
}

/*---
    external getsockopt:
        ('af,'st) t -> 'v untagged_sockopt_t -> 'v = "cf_socket_getsockopt"
  ---*/
CAMLprim value cf_socket_getsockopt(value sockVal, value optVal)
{
    CAMLparam2(sockVal, optVal);
    CAMLlocal1(resultVal);
    
    const Cf_socket_option_t** optPtrPtr;
    const Cf_socket_t* sockPtr;
    Cf_socket_option_context_t xopt;
    Cf_socket_getsockopt_f getF;
    
    sockPtr = Cf_socket_val(sockVal);
    optPtrPtr = Cf_socket_option_val(optVal);
    getF = (*optPtrPtr)->opt_get;
    if (!getF) {
	char failStr[80];
	sprintf(failStr, "Cf_socket.getsockopt %s not implemented.",
		(*optPtrPtr)->opt_name_str);
	failwith(failStr);
    }
    xopt.xopt_fd = sockPtr->s_fd;
    xopt.xopt_level = (*optPtrPtr)->opt_level;
    xopt.xopt_name = (*optPtrPtr)->opt_name;
    resultVal = getF(&xopt);
    
    CAMLreturn(resultVal);
}

/*---
    external setsockopt:
        ('af,'st) t -> 'v untagged_sockopt_t -> 'v -> unit =
        "cf_socket_setsockopt"
  ---*/
CAMLprim void cf_socket_setsockopt(value sockVal, value optVal, value setVal)
{
    CAMLparam3(sockVal, optVal, setVal);
    
    const Cf_socket_option_t** optPtrPtr;
    const Cf_socket_t* sockPtr;
    Cf_socket_option_context_t xopt;
    Cf_socket_setsockopt_f setF;
    
    sockPtr = Cf_socket_val(sockVal);
    optPtrPtr = Cf_socket_option_val(optVal);
    setF = (*optPtrPtr)->opt_set;
    if (!setF) {
        char failStr[80];
        sprintf(failStr, "Cf_socket.setsockopt %s not implemented.",
            (*optPtrPtr)->opt_name_str);
        failwith(failStr);
    }
    xopt.xopt_fd = sockPtr->s_fd;
    xopt.xopt_level = (*optPtrPtr)->opt_level;
    xopt.xopt_name = (*optPtrPtr)->opt_name;
    setF(&xopt, setVal);
    
    CAMLreturn0;
}

/*---
    type sockopt_index_t =
        SO_DEBUG | SO_REUSEADDR | SO_REUSEPORT | SO_KEEPALIVE | SO_DONTROUTE |
        SO_LINGER | SO_BROADCAST | SO_OOBINLINE | SO_SNDBUF | SO_RCVBUF |
        SO_SNDLOWAT | SO_RCVLOWAT | SO_SNDTIMEO | SO_RCVTIMEO | SO_ERROR |
        SO_NOSIGPIPE
  ---*/
static Cf_socket_sockopt_lift_t cf_socket_sockopt_lift_array[] = {
    { /* SO_DEBUG */
        Val_unit,
        {
            SOL_SOCKET, SO_DEBUG,
            cf_socket_getsockopt_bool, cf_socket_setsockopt_bool
        }
    },
    
    { /* SO_REUSEADDR */
        Val_unit,
        {
            SOL_SOCKET, SO_REUSEADDR,
            cf_socket_getsockopt_bool, cf_socket_setsockopt_bool
        }
    },

#ifdef SO_REUSEPORT
    { /* SO_REUSEPORT */
        Val_unit,
        {
            SOL_SOCKET, SO_REUSEPORT,
            cf_socket_getsockopt_bool, cf_socket_setsockopt_bool
        }
    },
#else
    { /* SO_REUSEPORT */
        Val_unit, { }
    },
#endif

    { /* SO_KEEPALIVE */
        Val_unit,
        {
            SOL_SOCKET, SO_KEEPALIVE,
            cf_socket_getsockopt_bool, cf_socket_setsockopt_bool
        }
    },

    { /* SO_DONTROUTE */
        Val_unit,
        {
            SOL_SOCKET, SO_DONTROUTE,
            cf_socket_getsockopt_bool, cf_socket_setsockopt_bool
        }
    },

    { /* SO_LINGER */
        Val_unit,
        {
            SOL_SOCKET, SO_LINGER,
            cf_socket_getsockopt_linger, cf_socket_setsockopt_linger
        }
    },

    { /* SO_BROADCAST */
        Val_unit,
        {
            SOL_SOCKET, SO_BROADCAST,
            cf_socket_getsockopt_bool, cf_socket_setsockopt_bool
        }
    },

    { /* SO_OOBINLINE */
        Val_unit,
        {
            SOL_SOCKET, SO_OOBINLINE,
            cf_socket_getsockopt_bool, cf_socket_setsockopt_bool
        }
    },

    { /* SO_SNDBUF */
        Val_unit,
        {
            SOL_SOCKET, SO_SNDBUF,
            cf_socket_getsockopt_int, cf_socket_setsockopt_int
        }
    },

    { /* SO_RCVBUF */
        Val_unit,
        {
            SOL_SOCKET, SO_RCVBUF,
            cf_socket_getsockopt_int, cf_socket_setsockopt_int
        }
    },

    { /* SO_SNDLOWAT */
        Val_unit,
        {
            SOL_SOCKET, SO_SNDLOWAT,
            cf_socket_getsockopt_int, cf_socket_setsockopt_int
        }
    },

    { /* SO_RCVLOWAT */
        Val_unit,
        {
            SOL_SOCKET, SO_RCVLOWAT,
            cf_socket_getsockopt_int, cf_socket_setsockopt_int
        }
    },

    { /* SO_SNDTIMEO */
        Val_unit,
        {
            SOL_SOCKET, SO_SNDTIMEO,
            cf_socket_getsockopt_timeout, cf_socket_setsockopt_timeout
        }
    },

    { /* SO_RCVTIMEO */
        Val_unit,
        {
            SOL_SOCKET, SO_RCVTIMEO,
            cf_socket_getsockopt_timeout, cf_socket_setsockopt_timeout
        }
    },

    { /* SO_ERROR */
        Val_unit,
        {
            SOL_SOCKET, SO_ERROR,
            cf_socket_getsockopt_error, cf_socket_setsockopt_bool
        }
    },

#ifdef SO_NOSIGPIPE
    { /* SO_NOSIGPIPE */
        Val_unit,
        {
            SOL_SOCKET, SO_NOSIGPIPE,
            cf_socket_getsockopt_bool, cf_socket_setsockopt_bool
        }
    }
#else
    { /* SO_NOSIGPIPE */
        Val_unit, { }
    }
#endif
};

#define CF_SOCKET_SOCKOPT_LIFT_ARRAY_SIZE \
    (sizeof cf_socket_sockopt_lift_array / \
        sizeof cf_socket_sockopt_lift_array[0])

/*---
    external sockopt_lift:
        sockopt_index_t -> ('a, 'b, 'c) sockopt_t = "cf_socket_sockopt_lift"
  ---*/
CAMLprim value cf_socket_sockopt_lift(value indexVal)
{
    CAMLparam1(indexVal);
    CAMLreturn(cf_socket_sockopt_lift_array[Int_val(indexVal)].ol_val);
}

/*---
  Initialization primitive
  ---*/
CAMLprim value cf_socket_init(value unit)
{
    int i;
    
    register_custom_operations(&cf_socket_op);
    register_custom_operations(&cf_socket_option_op);
        
    for (i = 0; i < CF_SOCKET_SOCKOPT_LIFT_ARRAY_SIZE; ++i) {        
        Cf_socket_sockopt_lift_t* liftPtr;
        
        liftPtr = &cf_socket_sockopt_lift_array[i];
        register_global_root(&liftPtr->ol_val);
        liftPtr->ol_val = cf_socket_option_alloc(&liftPtr->ol_option);
    }

    return Val_unit;
}

/*--- End of File [ cf_socket_p.c ] ---*/