Supporting socket2fd on Windows

Credit: Tamar Christina <[email protected]>

Author: kazu-yamamoto

Network/Socket/Types.hsc

@@ -174,6 +174,16 @@ withFdSocket (Socket ref _) f = do
 --   duplicated file descriptor.
 socketToFd :: Socket -> IO CInt
 socketToFd s = do
+#if defined(mingw32_HOST_OS)
+    fd <- unsafeFdSocket s
+    fd2 <- c_wsaDuplicate fd
+    -- FIXME: throw error no if -1
+    close s
+    return fd2
+
+foreign import ccall unsafe "wsaDuplicate"
+   c_wsaDuplicate :: CInt -> IO CInt
+#else
     fd <- unsafeFdSocket s
     -- FIXME: throw error no if -1
     fd2 <- c_dup fd
@@ -182,6 +192,7 @@ socketToFd s = do
 
 foreign import ccall unsafe "dup"
    c_dup :: CInt -> IO CInt
+#endif
 
 -- | Creating a socket from a file descriptor.
 mkSocket :: CInt -> IO Socket

cbits/initWinSock.c

@@ -40,4 +40,19 @@ initWinSock ()
   return 0;
 }
 
+SOCKET
+wsaDuplicate (SOCKET s)
+{
+  WSAPROTOCOL_INFOW protocolInfo;
+  if (WSADuplicateSocketW (s, GetCurrentProcessId (), &protocolInfo) != 0)
+    return -1;
+
+  SOCKET res = WSASocketW(FROM_PROTOCOL_INFO, FROM_PROTOCOL_INFO,
+                          FROM_PROTOCOL_INFO, &protocolInfo, 0, 0);
+  if (res == SOCKET_ERROR)
+    return -1;
+
+  return res;
+}
+
 #endif

tests/Network/SocketSpec.hs

@@ -209,3 +209,13 @@ spec = do
                     threadDelay 10000
                     void $ recv sock 1024
             tcpTest client server
+
+    describe "socketToFd" $ do
+        it "socketToFd can send using fd" $ do
+            let server sock = do
+                    void $ recv sock 1024
+                client sock = do
+                    fd <- socketToFd sock
+                    s <- mkSocket fd
+                    sendAll s "HELLO WORLD"
+            tcpTest client server