CAMLprim value win_check_connection (value socket, value kind, value idx) {
CAMLparam3 (socket, kind, idx);
WSANETWORKEVENTS evs;
int res, err, i = Long_val(idx);
D(printf("Check connection... %d\n", i));
if (WSAEnumNetworkEvents(Socket_val(socket), NULL, &evs)) {
win32_maperr(WSAGetLastError ());
uerror("WSAEnumNetworkEvents", Nothing);
}
if (WSAEventSelect(Socket_val(socket), NULL, 0) == SOCKET_ERROR) {
win32_maperr(WSAGetLastError ());
uerror("WSAEventSelect", Nothing);
}
if (!CloseHandle(events[i])) {
win32_maperr(GetLastError ());
uerror("CloseHandle", Nothing);
}
err =
evs.iErrorCode[(Long_val(kind) == 0) ? FD_CONNECT_BIT : FD_ACCEPT_BIT];
D(printf("Check connection: %ld, err %d\n", evs.lNetworkEvents, err));
if (err != 0) {
win32_maperr(err);
uerror("check_connection", Nothing);
}
CAMLreturn (Val_unit);
}
CAMLprim value unix_read(value fd, value buf, value ofs, value vlen)
{
intnat len;
DWORD numbytes, numread;
char iobuf[UNIX_BUFFER_SIZE];
DWORD err = 0;
Begin_root (buf);
len = Long_val(vlen);
numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
enter_blocking_section();
ret = recv(s, iobuf, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
leave_blocking_section();
numread = ret;
} else {
HANDLE h = Handle_val(fd);
enter_blocking_section();
if (! ReadFile(h, iobuf, numbytes, &numread, NULL))
err = GetLastError();
leave_blocking_section();
}
if (err) {
win32_maperr(err);
uerror("read", Nothing);
}
memmove (&Byte(buf, Long_val(ofs)), iobuf, numread);
End_roots();
return Val_int(numread);
}
CAMLprim value unix_recv(value sock, value buff, value ofs, value len,
value flags)
{
SOCKET s = Socket_val(sock);
int flg = convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
DWORD err = 0;
Begin_root (buff);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
enter_blocking_section();
ret = recv(s, iobuf, (int) numbytes, flg);
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("recv", Nothing);
}
memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
End_roots();
return Val_int(ret);
}
CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags)
{
SOCKET s = Socket_val(sock);
int flg = convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
value res;
value adr = Val_unit;
union sock_addr_union addr;
socklen_param_type addr_len;
DWORD err = 0;
Begin_roots2 (buff, adr);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
addr_len = sizeof(sock_addr);
enter_blocking_section();
ret = recvfrom(s, iobuf, (int) numbytes, flg, &addr.s_gen, &addr_len);
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("recvfrom", Nothing);
}
memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
adr = alloc_sockaddr(&addr, addr_len, -1);
res = alloc_small(2, 0);
Field(res, 0) = Val_int(ret);
Field(res, 1) = adr;
End_roots();
return res;
}
CAMLprim value ocaml_ssl_embed_socket(value socket_, value context)
{
CAMLparam1(context);
CAMLlocal1(block);
#ifdef Socket_val
SOCKET socket = Socket_val(socket_);
#else
int socket = Int_val(socket_);
#endif
SSL_CTX *ctx = Ctx_val(context);
SSL *ssl;
block = caml_alloc_custom(&socket_ops, sizeof(SSL*), 0, 1);
if (socket < 0)
caml_raise_constant(*caml_named_value("ssl_exn_invalid_socket"));
caml_enter_blocking_section();
ssl = SSL_new(ctx);
if (!ssl)
{
caml_leave_blocking_section();
caml_raise_constant(*caml_named_value("ssl_exn_handler_error"));
}
SSL_set_fd(ssl, socket);
caml_leave_blocking_section();
SSL_val(block) = ssl;
CAMLreturn(block);
}
CAMLprim value recv_stub(value socket, value rcv_option) {
CAMLparam2 (socket, rcv_option);
CAMLlocal1 (message);
void *sock = Socket_val(socket)->wrapped;
zmq_msg_t request;
int result = zmq_msg_init (&request);
stub_raise_if (result == -1);
caml_release_runtime_system();
result = zmq_recvmsg(sock, &request, Int_val(rcv_option));
caml_acquire_runtime_system();
stub_raise_if (result == -1);
size_t size = zmq_msg_size (&request);
if (size == 0) {
message = EMPTY_STRING;
} else {
message = caml_alloc_string(size);
memcpy (String_val(message), zmq_msg_data (&request), size);
}
result = zmq_msg_close(&request);
stub_raise_if (result == -1);
CAMLreturn (message);
}
value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest)
{
SOCKET s = Socket_val(sock);
int flg = convert_flag_list(flags, msg_flag_table);
int ret;
intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
union sock_addr_union addr;
socklen_param_type addr_len;
DWORD err = 0;
get_sockaddr(dest, &addr, &addr_len);
numbytes = Long_val(len);
if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes);
enter_blocking_section();
ret = sendto(s, iobuf, (int) numbytes, flg, &addr.s_gen, addr_len);
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) {
win32_maperr(err);
uerror("sendto", Nothing);
}
return Val_int(ret);
}
CAMLprim value lwt_unix_read(value fd, value buf, value vofs, value vlen)
{
intnat ofs, len, written;
DWORD numbytes, numwritten;
DWORD err = 0;
Begin_root (buf);
ofs = Long_val(vofs);
len = Long_val(vlen);
written = 0;
if (len > 0) {
numbytes = len;
if (Descr_kind_val(fd) == KIND_SOCKET) {
int ret;
SOCKET s = Socket_val(fd);
ret = recv(s, &Byte(buf, ofs), numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
numwritten = ret;
} else {
HANDLE h = Handle_val(fd);
if (! ReadFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL))
err = GetLastError();
}
if (err) {
win32_maperr(err);
uerror("write", Nothing);
}
written = numwritten;
}
End_roots();
return Val_long(written);
}
CAMLprim value
stub_ba_send(value fd, value val_buf, value val_ofs, value val_len)
{
CAMLparam4(fd, val_buf, val_ofs, val_len);
int ret = 0;
#ifdef WIN32
char *data = (char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs);
size_t c_len = Int_val(val_len);
SOCKET s = Socket_val(fd);
DWORD err = 0;
caml_release_runtime_system();
ret = send(s, data, c_len, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
caml_acquire_runtime_system();
if (err) {
win32_maperr(err);
uerror("read", Nothing);
}
#else
caml_failwith("AF_HYPERV only available on Windows");
#endif
CAMLreturn(Val_int(ret));
}
value ml_setsock_iptos_throughput(value sock_v)
{
int sock = Socket_val(sock_v);
int tos = IPTOS_THROUGHPUT /* IPTOS_MINCOST obsoleted by ECN */;
return Val_int(setsockopt(sock,
IPPROTO_IP, IP_TOS,
&tos, sizeof(tos)));
}
value skt_close(value sock_v, value addr_v){
int ret;
ret = closesocket(Socket_val(sock_v));
if (ret == -1) serror("socketclose");
SKTTRACE(("skt_close\n"));
return Val_unit;
}
value win_alloc_socket(SOCKET s)
{
value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
Socket_val(res) = s;
Descr_kind_val(res) = KIND_SOCKET;
CRT_fd_val(res) = NO_CRT_FD;
return res;
}
value iocp_ml_accept(value ListenSocket)
{
CAMLparam1(ListenSocket);
CAMLlocal1(res);
SOCKET so = Socket_val(ListenSocket);
res = Val_int(async_accept(so));
CAMLreturn(res);
}
value ml_get_fd_num(value fd)
{
#if defined(__MINGW32__)
return Int_val(Socket_val(fd));
#else
return fd;
#endif
}
CAMLexport value
unix_getsockopt_aux(char * name,
enum option_type ty, int level, int option,
value socket)
{
union option_value optval;
socklen_param_type optsize;
switch (ty) {
case TYPE_BOOL:
case TYPE_INT:
case TYPE_UNIX_ERROR:
optsize = sizeof(optval.i); break;
case TYPE_LINGER:
optsize = sizeof(optval.lg); break;
case TYPE_TIMEVAL:
optsize = sizeof(optval.tv); break;
default:
unix_error(EINVAL, name, Nothing);
}
if (getsockopt(Socket_val(socket), level, option,
(void *) &optval, &optsize) == -1)
uerror(name, Nothing);
switch (ty) {
case TYPE_BOOL:
case TYPE_INT:
return Val_int(optval.i);
case TYPE_LINGER:
if (optval.lg.l_onoff == 0) {
return Val_int(0); /* None */
} else {
value res = alloc_small(1, 0); /* Some */
Field(res, 0) = Val_int(optval.lg.l_linger);
return res;
}
case TYPE_TIMEVAL:
return copy_double((double) optval.tv.tv_sec
+ (double) optval.tv.tv_usec / 1e6);
case TYPE_UNIX_ERROR:
if (optval.i == 0) {
return Val_int(0); /* None */
} else {
value err, res;
err = unix_error_of_code(optval.i);
Begin_root(err);
res = alloc_small(1, 0); /* Some */
Field(res, 0) = err;
End_roots();
return res;
}
default:
unix_error(EINVAL, name, Nothing);
return Val_unit; /* Avoid warning */
}
}
value skt_listen(value sock_v, value backlog_v){
int ret;
SKTTRACE(("skt_listen(\n"));
ret = listen(Socket_val(sock_v), Int_val(backlog_v));
SKTTRACE2(("skt_listen)\n"));
if (ret == -1) serror("listen");
return Val_unit;
}
value ml_add_fd_to_event_set(value task_v)
{
int fd = Socket_val(Field(task_v,FD_TASK_FD));
int must_read = ((Field(task_v, FD_TASK_RLEN) != Val_int(0)) &&
(Field(Field(task_v, FD_TASK_READ_ALLOWED),0) == Val_true));
int must_write = ( (Field(task_v, FD_TASK_WLEN) != Val_int(0)) &&
(Field(Field(task_v, FD_TASK_WRITE_ALLOWED),0) == Val_true));
return Val_unit;
}
CAMLprim value iocp_ml_read(value fd, value vlen)
{
CAMLparam2(fd, vlen);
CAMLlocal1(res);
intnat len = Long_val(vlen);
SOCKET s = Socket_val(fd);
assert(Descr_kind_val(fd) == KIND_SOCKET);
res = Val_int(async_read(s, len));
CAMLreturn(res);
}
value skt_bind(value sock_v, value addr_v)
{
int ret;
union sock_addr_union addr;
socklen_param_type addr_len;
get_sockaddr(addr_v, &addr, &addr_len);
ret = bind(Socket_val(sock_v), (struct sockaddr*) &addr.s_inet, addr_len);
if (ret == -1) serror("bind");
SKTTRACE(("bind\n"));
return Val_unit;
}
CAMLprim value setsockopt_stub(value sock, value sockopt, value val) {
CAMLparam3 (sock, sockopt, val);
int native_sockopt = Int_val(sockopt);
struct wrap *socket = Socket_val(sock);
int result = -1;
switch (native_sockopt) {
case ZMQ_SNDHWM:
case ZMQ_RCVHWM:
case ZMQ_RATE:
case ZMQ_RECOVERY_IVL:
case ZMQ_SNDBUF:
case ZMQ_RCVBUF:
case ZMQ_LINGER:
case ZMQ_RECONNECT_IVL_MAX:
case ZMQ_BACKLOG:
case ZMQ_MULTICAST_HOPS:
case ZMQ_RCVTIMEO:
case ZMQ_SNDTIMEO:
{
int optval = Int_val(val);
result = zmq_setsockopt(socket->wrapped, native_sockopt, &optval, sizeof(optval));
}
break;
case ZMQ_IDENTITY:
case ZMQ_SUBSCRIBE:
case ZMQ_UNSUBSCRIBE:
{
result = zmq_setsockopt(socket->wrapped,
native_sockopt,
String_val(val),
caml_string_length(val));
}
break;
case ZMQ_AFFINITY:
case ZMQ_MAXMSGSIZE:
{
int64 optval = Int64_val(val);
result = zmq_setsockopt(socket->wrapped, native_sockopt, &optval, sizeof(optval));
}
break;
default:
caml_failwith("Bidings error");
}
stub_raise_if (result == -1);
CAMLreturn (Val_unit);
}
value skt_connect(value sock_v, value address){
union sock_addr_union addr;
socklen_param_type addr_len;
int ret;
get_sockaddr(address, &addr, &addr_len);
ret = WSAConnect(Socket_val(sock_v), (struct sockaddr*) &addr.s_inet, addr_len,
NULL, NULL, NULL, NULL);
if (ret < 0) serror("skt_connect") ;
SKTTRACE(("skt_connect\n"));
return Val_unit;
}
CAMLprim value netsys_int64_of_file_descr(value fd) {
#ifdef _WIN32
switch (Descr_kind_val(fd)) {
case KIND_HANDLE:
return copy_int64((intnat) (Handle_val(fd)));
case KIND_SOCKET:
return copy_int64((intnat) (Socket_val(fd)));
}
return copy_int64(0);
#else
return copy_int64(Long_val(fd));
#endif
}
CAMLprim value iocp_ml_write(value fd, value vbuf, value vlen)
{
CAMLparam3(fd, vbuf, vlen);
CAMLlocal1(res);
intnat len = Long_val(vlen);
SOCKET s = Socket_val(fd);
char *buf = String_val(vbuf);
assert(Descr_kind_val(fd) == KIND_SOCKET);
res = Val_int(async_write(s, buf, len));
CAMLreturn(res);
/* async_write(s, buf, len); */
/* return Val_unit; */
}
/* Set size of receive buffers.
*/
value skt_setsockopt_recvbuf( /* ML */
value sock_v,
value size_v
)
{
int size = Int_val(size_v) ;
int sock = Socket_val(sock_v) ;
int ret ;
ret = setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (void*)&size, sizeof(size)) ;
if (ret < 0) serror("setsockopt:recvbuf");
return Val_int(ret) ;
}
CAMLprim value stub_setSocketTTL(value s, value ttl){
CAMLparam2(s, ttl);
int c_ttl = Int_val(ttl);
#ifdef WIN32
SOCKET c_s = Socket_val(s);
if (setsockopt(c_s, IPPROTO_IP, IP_TTL, (const char *)&c_ttl, sizeof(c_ttl)) != 0) {
win32_maperr(GetLastError());
#else
int c_fd = Int_val(s);
if (setsockopt(c_fd, IPPROTO_IP, IP_TTL, &c_ttl, sizeof(c_ttl)) != 0) {
#endif
unix_error(errno, "setsockopt", Nothing);
}
CAMLreturn(Val_unit);
}
CAMLprim value unix_close(value fd)
{
if (Descr_kind_val(fd) == KIND_SOCKET) {
if (closesocket(Socket_val(fd)) != 0) {
win32_maperr(WSAGetLastError());
uerror("close", Nothing);
}
} else {
if (! CloseHandle(Handle_val(fd))) {
win32_maperr(GetLastError());
uerror("close", Nothing);
}
}
return Val_unit;
}
CAMLprim value close_stub(value sock) {
CAMLparam1 (sock);
struct wrap *socket = Socket_val(sock);
if (!socket->terminated) {
caml_release_runtime_system();
int result = zmq_close(socket->wrapped);
caml_acquire_runtime_system();
stub_raise_if (result == -1);
socket->terminated = 1;
}
CAMLreturn (Val_unit);
}
/* Set size of receive buffers.
*/
value skt_setsockopt_reuse( /* ML */
value sock_v,
value onoff_v
)
{
BOOL size = Int_val(onoff_v) ;
int sock = Socket_val(sock_v) ;
int ret ;
ret = setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,(char*)&size, sizeof(size)) ;
SKTTRACE(("skt_sock_resuse\n"));
if (ret == -1) serror("setsockopt:reuse");
return Val_unit;
}
/* Convert fdlist to an fd_set if all the handles in fdlist are sockets and return 0.
* Returns 1 if a non-socket value is encountered.
*/
static int fdlist_to_fdset(value fdlist, fd_set *fdset)
{
value l, c;
FD_ZERO(fdset);
for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
c = Field(l, 0);
if (Descr_kind_val(c) == KIND_SOCKET) {
FD_SET(Socket_val(c), fdset);
} else {
DEBUG_PRINT("Non socket value encountered");
return 0;
}
}
return 1;
}
CAMLprim value win_register_wait (value socket, value kind, value idx) {
CAMLparam3(socket, kind, idx);
long i = Long_val(idx);
long mask;
D(printf("Register: i %ld, kind %ld\n", Long_val(i), Long_val(kind)));
events[i] = CreateEvent(NULL, TRUE, FALSE, NULL);
mask = (Long_val(kind) == 0) ? FD_CONNECT : FD_ACCEPT;
if (WSAEventSelect(Socket_val(socket), events[i], mask) == SOCKET_ERROR) {
win32_maperr(WSAGetLastError ());
uerror("WSAEventSelect", Nothing);
}
CAMLreturn (Val_unit);
}