Merge pull request #910 from MisterDA/windows-socket-WSASocket-WSA_FL…

…AG_NO_HANDLE_INHERIT Use `WSA_FLAG_NO_HANDLE_INHERIT` on Windows for cloexec sockets
ocsigen · Apr 12, 2022 · 6d8eb07 · 6d8eb07
2 parents 57c0a5d + e47ee13
commit 6d8eb07
Show file tree

Hide file tree

Showing 3 changed files with 68 additions and 33 deletions.
diff --git a/CHANGES b/CHANGES
@@ -16,6 +16,7 @@
   * Prefer SetHandleInformation to DuplicateHandle in set_close_on_exec for sockets. DuplicateHandle mustn't be used on sockets. (#907, Antonin Décimo)
   * Lwt.pick and Lwt.choose select preferentially failed promises as per
   documentation (#856, #874, Raman Varabets)
+  * Use the WSA_FLAG_NO_HANDLE_INHERIT on Windows when creating sockets with WSASocket if the cloexec (non-inheritable) parameter is true. Fixes a Windows problem where a child process would inherit a supposedly non-inheritable socket. (#910, Antonin Décimo)
 
 ====== Deprecations ======
 

diff --git a/src/unix/lwt_unix.cppo.ml b/src/unix/lwt_unix.cppo.ml
@@ -1724,17 +1724,7 @@ let shutdown ch shutdown_command =
   check_descriptor ch;
   Unix.shutdown ch.fd shutdown_command
 
-external stub_socketpair : socket_domain -> socket_type -> int -> Unix.file_descr * Unix.file_descr = "lwt_unix_socketpair_stub"
-
-#if OCAML_VERSION >= (4, 05, 0)
-let stub_socketpair ?cloexec dom typ proto =
-  let (s1, s2) = stub_socketpair dom typ proto in
-  if cloexec = Some true then begin
-    Unix.set_close_on_exec s1;
-    Unix.set_close_on_exec s2
-  end;
-  (s1, s2)
-#endif
+external stub_socketpair : ?cloexec:bool -> socket_domain -> socket_type -> int -> Unix.file_descr * Unix.file_descr = "lwt_unix_socketpair_stub"
 
 let socketpair ?cloexec dom typ proto =
   let (s1, s2) =
@@ -1746,12 +1736,15 @@ let socketpair ?cloexec dom typ proto =
     if Sys.win32 then stub_socketpair ?cloexec dom typ proto
     else Unix.socketpair ?cloexec dom typ proto in
 #else
-    if Sys.win32 then stub_socketpair dom typ proto
-    else Unix.socketpair dom typ proto in
-  if cloexec = Some true then begin
-    Unix.set_close_on_exec s1;
-    Unix.set_close_on_exec s2
-  end;
+    if Sys.win32 then stub_socketpair ?cloexec dom typ proto
+    else begin
+      let (s1, s2) = Unix.socketpair dom typ proto in
+      if cloexec = Some true then begin
+        Unix.set_close_on_exec s1;
+        Unix.set_close_on_exec s2
+      end;
+      (s1, s2)
+    end in
 #endif
   (mk_ch ~blocking:false s1, mk_ch ~blocking:false s2)
 

diff --git a/src/unix/lwt_unix_stubs.c b/src/unix/lwt_unix_stubs.c
@@ -342,8 +342,57 @@ void lwt_unix_condition_wait(lwt_unix_condition *condition,
 
 #if defined(LWT_ON_WINDOWS)
 
+#if OCAML_VERSION < 41400
+static int win_set_inherit(HANDLE fd, BOOL inherit)
+{
+  if (! SetHandleInformation(fd,
+                             HANDLE_FLAG_INHERIT,
+                             inherit ? HANDLE_FLAG_INHERIT : 0)) {
+    win32_maperr(GetLastError());
+    return -1;
+  }
+  return 0;
+}
+#endif
+
+static SOCKET lwt_win_socket(int domain, int type, int protocol,
+                             LPWSAPROTOCOL_INFO info,
+                             BOOL inherit)
+{
+  SOCKET s;
+  DWORD flags = WSA_FLAG_OVERLAPPED;
+
+#ifndef WSA_FLAG_NO_HANDLE_INHERIT
+#define WSA_FLAG_NO_HANDLE_INHERIT 0x80
+#endif
+
+  if (! inherit)
+    flags |= WSA_FLAG_NO_HANDLE_INHERIT;
+
+  s = WSASocket(domain, type, protocol, info, 0, flags);
+  if (s == INVALID_SOCKET) {
+    if (! inherit && WSAGetLastError() == WSAEINVAL) {
+      /* WSASocket probably doesn't suport WSA_FLAG_NO_HANDLE_INHERIT,
+       * retry without. */
+      flags &= ~(DWORD)WSA_FLAG_NO_HANDLE_INHERIT;
+      s = WSASocket(domain, type, protocol, info, 0, flags);
+      if (s == INVALID_SOCKET)
+        goto err;
+      win_set_inherit((HANDLE) s, FALSE);
+      return s;
+    }
+    goto err;
+  }
+
+  return s;
+
+ err:
+  win32_maperr(WSAGetLastError());
+  return INVALID_SOCKET;
+}
+
 static void lwt_unix_socketpair(int domain, int type, int protocol,
-                                SOCKET sockets[2]) {
+                                SOCKET sockets[2], BOOL inherit) {
   union {
     struct sockaddr_in inaddr;
     struct sockaddr_in6 inaddr6;
@@ -360,7 +409,7 @@ static void lwt_unix_socketpair(int domain, int type, int protocol,
   sockets[0] = INVALID_SOCKET;
   sockets[1] = INVALID_SOCKET;
 
-  listener = socket(domain, type, protocol);
+  listener = lwt_win_socket(domain, type, protocol, NULL, inherit);
   if (listener == INVALID_SOCKET) goto failure;
 
   memset(&a, 0, sizeof(a));
@@ -394,7 +443,7 @@ static void lwt_unix_socketpair(int domain, int type, int protocol,
 
   if (listen(listener, 1) == SOCKET_ERROR) goto failure;
 
-  sockets[0] = socket(domain, type, protocol);
+  sockets[0] = lwt_win_socket(domain, type, protocol, NULL, inherit);
   if (sockets[0] == INVALID_SOCKET) goto failure;
 
   addrlen = domain == PF_INET ? sizeof(a.inaddr) : sizeof(a.inaddr6);
@@ -421,14 +470,15 @@ static int socket_domain_table[] = {PF_UNIX, PF_INET, PF_INET6};
 static int socket_type_table[] = {SOCK_STREAM, SOCK_DGRAM, SOCK_RAW,
                                   SOCK_SEQPACKET};
 
-CAMLprim value lwt_unix_socketpair_stub(value domain, value type,
+CAMLprim value lwt_unix_socketpair_stub(value cloexec, value domain, value type,
                                         value protocol) {
-  CAMLparam3(domain, type, protocol);
+  CAMLparam4(cloexec, domain, type, protocol);
   CAMLlocal1(result);
   SOCKET sockets[2];
   lwt_unix_socketpair(socket_domain_table[Int_val(domain)],
                       socket_type_table[Int_val(type)], Int_val(protocol),
-                      sockets);
+                      sockets,
+                      ! unix_cloexec_p(cloexec));
   result = caml_alloc_tuple(2);
   Store_field(result, 0, win_alloc_socket(sockets[0]));
   Store_field(result, 1, win_alloc_socket(sockets[1]));
@@ -608,13 +658,6 @@ value lwt_unix_recv_notifications() {
 
 #if defined(LWT_ON_WINDOWS)
 
-static void set_close_on_exec(SOCKET socket) {
-  if (!SetHandleInformation(socket, HANDLE_FLAG_INHERIT, 0)) {
-    win32_maperr(GetLastError());
-    uerror("set_close_on_exec", Nothing);
-  }
-}
-
 static SOCKET socket_r, socket_w;
 
 static int windows_notification_send() {
@@ -648,10 +691,8 @@ value lwt_unix_init_notification() {
 
   /* Since pipes do not works with select, we need to use a pair of
      sockets. */
-  lwt_unix_socketpair(AF_INET, SOCK_STREAM, IPPROTO_TCP, sockets);
+  lwt_unix_socketpair(AF_INET, SOCK_STREAM, IPPROTO_TCP, sockets, FALSE);
 
-  set_close_on_exec(sockets[0]);
-  set_close_on_exec(sockets[1]);
   socket_r = sockets[0];
   socket_w = sockets[1];
   notification_mode = NOTIFICATION_MODE_WINDOWS;