Emulate socketpair of Unix domain sockets of stream type on Windows

Windows does not provide an implementation of socketpair.
This emulates the behaviour of socketpair on Unix domain sockets of
SOCK_STREAM type.

Related to ocaml/ocaml pull#9104.

Changes

@@ -86,6 +86,10 @@ Working version
 - #10185: Consider that IPv6 is always enabled on Windows.
   (Antonin Décimo, review by David Allsopp and Xavier Leroy)
 
+- #10192: Add support for Unix domain sockets on Windows and use them
+  to emulate Unix.socketpair (only available on Windows 1803+)
+  (Antonin Décimo, review by David Allsopp)
+
 ### Tools:
 
 - #10139: Remove confusing navigation bar from stdlib documentation.

configure.ac

@@ -1295,7 +1295,8 @@ sockets=true
 AS_CASE([$host],
   [*-*-mingw32|*-pc-windows],
     [cclibs="$cclibs -lws2_32"
-    AC_SEARCH_LIBS([socket], [ws2_32])],
+    AC_SEARCH_LIBS([socket], [ws2_32])
+    AC_CHECK_FUNC([socketpair], [AC_DEFINE([HAS_SOCKETPAIR])])],
   [*-*-haiku],
     [cclibs="$cclibs -lnetwork"
     AC_SEARCH_LIBS([socket], [network])],

otherlibs/win32unix/Makefile

@@ -24,7 +24,7 @@ WIN_FILES = accept.c bind.c channels.c close.c \
   link.c listen.c lockf.c lseek.c nonblock.c \
   mmap.c open.c pipe.c read.c readlink.c rename.c \
   select.c sendrecv.c \
-  shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
+  shutdown.c sleep.c socket.c socketpair.c sockopt.c startup.c stat.c \
   symlink.c system.c times.c truncate.c unixsupport.c windir.c winwait.c \
   write.c winlist.c winworker.c windbug.c utimes.c
 

otherlibs/win32unix/socketpair.c

@@ -0,0 +1,201 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                         Antonin Decimo, Tarides                        */
+/*                                                                        */
+/*   Copyright 2021 Tarides                                               */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/misc.h>
+#include <caml/signals.h>
+#include "unixsupport.h"
+#include <errno.h>
+
+#ifdef HAS_SOCKETS
+
+#include "socketaddr.h"
+#include <ws2tcpip.h>
+
+extern int socket_domain_table[]; /* from socket.c */
+extern int socket_type_table[]; /* from socket.c */
+
+#ifdef HAS_SOCKETPAIR
+
+#error "Windows has defined sockepair! win32unix should be updated."
+
+#else
+
+static int socketpair(int domain, int type, int protocol,
+                      SOCKET socket_vector[2])
+{
+  wchar_t dirname[MAX_PATH + 1], path[MAX_PATH + 1];
+  union sock_addr_union addr;
+  socklen_param_type socklen;
+
+  /* POSIX states that in case of error, the contents of socket_vector
+     shall be unmodified. */
+  SOCKET listener = INVALID_SOCKET,
+    server = INVALID_SOCKET,
+    client = INVALID_SOCKET;
+
+  fd_set writefds, exceptfds;
+  u_long non_block, peerid = 0UL;
+
+  DWORD drc;
+  int rc;
+
+  if (GetTempPath(MAX_PATH + 1, dirname) == 0) {
+    win32_maperr(GetLastError());
+    goto fail;
+  }
+
+  if (GetTempFileName(dirname, L"osp", 0U, path) == 0) {
+    win32_maperr(GetLastError());
+    goto fail;
+  }
+
+  addr.s_unix.sun_family = PF_UNIX;
+  socklen = sizeof(addr.s_unix);
+
+  /* sun_path needs to be set in UTF-8 */
+  rc = WideCharToMultiByte(CP_UTF8, 0, path, -1, addr.s_unix.sun_path,
+                           UNIX_PATH_MAX, NULL, NULL);
+  if (rc == 0) {
+    win32_maperr(GetLastError());
+    goto fail_path;
+  }
+
+  listener = socket(domain, type, protocol);
+  if (listener == INVALID_SOCKET)
+    goto fail_wsa;
+
+  /* The documentation requires removing the file before binding the socket. */
+  if (DeleteFile(path) == 0) {
+    drc = GetLastError();
+    if (drc != ERROR_FILE_NOT_FOUND) {
+      win32_maperr(drc);
+      goto fail_sockets;
+    }
+  }
+
+  rc = bind(listener, (struct sockaddr *) &addr, socklen);
+  if (rc == SOCKET_ERROR)
+    goto fail_wsa;
+
+  rc = listen(listener, 1);
+  if (rc == SOCKET_ERROR)
+    goto fail_wsa;
+
+  client = socket(domain, type, protocol);
+  if (client == INVALID_SOCKET)
+    goto fail_wsa;
+
+  non_block = 1UL;
+  if (ioctlsocket(client, FIONBIO, &non_block) == SOCKET_ERROR)
+    goto fail_wsa;
+
+  rc = connect(client, (struct sockaddr *) &addr, socklen);
+  if (rc != SOCKET_ERROR || WSAGetLastError() != WSAEWOULDBLOCK)
+    goto fail_wsa;
+
+  server = accept(listener, NULL, NULL);
+  if (server == INVALID_SOCKET)
+    goto fail_wsa;
+
+  rc = closesocket(listener);
+  listener = INVALID_SOCKET;
+  if (rc == SOCKET_ERROR)
+    goto fail_wsa;
+
+  FD_ZERO(&writefds);
+  FD_SET(client, &writefds);
+  FD_ZERO(&exceptfds);
+  FD_SET(client, &exceptfds);
+
+  rc = select(0, NULL, &writefds, &exceptfds, NULL /* blocking */);
+  if (rc == SOCKET_ERROR
+      || FD_ISSET(client, &exceptfds)
+      || !FD_ISSET(client, &writefds)) {
+    /* We're not interested in the socket error status */
+    goto fail_wsa;
+  }
+
+  non_block = 0UL;
+  if (ioctlsocket(client, FIONBIO, &non_block) == SOCKET_ERROR)
+    goto fail_wsa;
+
+  if (DeleteFile(path) == 0) {
+    win32_maperr(GetLastError());
+    goto fail_sockets;
+  }
+
+  rc = WSAIoctl(client, SIO_AF_UNIX_GETPEERPID,
+                NULL, 0U,
+                &peerid, sizeof(peerid), &drc /* Windows bug: always 0 */,
+                NULL, NULL);
+  if (rc == SOCKET_ERROR || peerid != GetCurrentProcessId())
+    goto fail_wsa;
+
+  socket_vector[0] = client;
+  socket_vector[1] = server;
+  return 0;
+
+fail_wsa:
+  win32_maperr(WSAGetLastError());
+
+fail_path:
+  DeleteFile(path);
+
+fail_sockets:
+  if(listener != INVALID_SOCKET)
+    closesocket(listener);
+  if(client != INVALID_SOCKET)
+    closesocket(client);
+  if(server != INVALID_SOCKET)
+    closesocket(server);
+
+fail:
+  return SOCKET_ERROR;
+}
+
+CAMLprim value unix_socketpair(value cloexec, value domain, value type,
+                               value protocol)
+{
+  CAMLparam4(cloexec, domain, type, protocol);
+  CAMLlocal3(res, s0, s1);
+  SOCKET sv[2];
+  int rc;
+
+  caml_enter_blocking_section();
+  rc = socketpair(socket_domain_table[Int_val(domain)],
+                  socket_type_table[Int_val(type)],
+                  Int_val(protocol),
+                  sv);
+  caml_leave_blocking_section();
+
+  if (rc == SOCKET_ERROR)
+    uerror("socketpair", Nothing);
+
+  win_set_cloexec((HANDLE) sv[0], cloexec);
+  win_set_cloexec((HANDLE) sv[1], cloexec);
+
+  s0 = win_alloc_socket(sv[0]);
+  s1 = win_alloc_socket(sv[1]);
+  res = caml_alloc_small(2, 0);
+  Field(res, 0) = s0;
+  Field(res, 1) = s1;
+  CAMLreturn(res);
+}
+
+#endif  /* HAS_SOCKETPAIR */
+
+#endif  /* HAS_SOCKETS */

otherlibs/win32unix/unix.ml

@@ -679,8 +679,10 @@ type msg_flag =
 external socket :
   ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
   = "unix_socket"
-let socketpair ?cloexec:_ _dom _ty _proto =
-  invalid_arg "Unix.socketpair not implemented"
+external socketpair :
+  ?cloexec: bool -> socket_domain -> socket_type -> int ->
+                                           file_descr * file_descr
+  = "unix_socketpair"
 external accept :
   ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
 external bind : file_descr -> sockaddr -> unit = "unix_bind"

runtime/caml/s.h.in

@@ -68,6 +68,11 @@
 
 /* Define HAS_SOCKETS if you have BSD sockets. */
 
+#undef HAS_SOCKETPAIR
+
+/* Define HAS_SOCKETPAIR if you have the socketpair function. Only
+   relevant on Windows. */
+
 #undef HAS_SOCKLEN_T
 
 /* Define HAS_SOCKLEN_T if the type socklen_t is defined in

testsuite/tests/lib-unix/win-socketpair/has-afunix.sh

@@ -0,0 +1,8 @@
+#!/bin/sh
+
+# Test if the OS runtime has afunix enabled.
+
+if sc query afunix > /dev/null; then
+  exit "${TEST_PASS}";
+fi
+exit "${TEST_SKIP}"

testsuite/tests/lib-unix/win-socketpair/test.ml

@@ -0,0 +1,32 @@
+(* TEST
+
+* libwin32unix
+   script = "sh ${test_source_directory}/has-afunix.sh"
+** hassysthreads
+    include systhreads
+*** script
+**** bytecode
+output = "${test_build_directory}/program-output"
+stdout = "${output}"
+**** native
+output = "${test_build_directory}/program-output"
+stdout = "${output}"
+
+ *)
+
+let peer id fd =
+  let msg = Bytes.of_string (Printf.sprintf "%d" id) in
+  ignore (Unix.write fd msg 0 (Bytes.length msg));
+  ignore (Unix.read fd msg 0 (Bytes.length msg));
+  let expected = Bytes.of_string (Printf.sprintf "%d" (if id = 0 then 1 else 0)) in
+  if msg = expected then
+    Printf.printf "Ok\n%!"
+  else
+    Printf.printf "%d: %s\n%!" id (Bytes.to_string msg);
+  flush_all ()
+
+let () =
+  let fd0, fd1 = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+  let t0, t1 = Thread.create (peer 0) fd0, Thread.create (peer 1) fd1 in
+  Thread.join t0; Thread.join t1;
+  Unix.close fd0; Unix.close fd1

testsuite/tests/lib-unix/win-socketpair/test.reference

@@ -0,0 +1,2 @@
+Ok
+Ok