Merge PR haskell#424

Author: kazu-yamamoto

Network/Socket.hs

@@ -141,6 +141,7 @@ module Network.Socket
     , withFdSocket
     , unsafeFdSocket
     , touchSocket
+    , socketToFd
     , fdSocket
     , mkSocket
     , socketToHandle

Network/Socket/Types.hsc

@@ -14,6 +14,7 @@ module Network.Socket.Types (
     , withFdSocket
     , unsafeFdSocket
     , touchSocket
+    , socketToFd
     , fdSocket
     , mkSocket
     , invalidateSocket
@@ -166,6 +167,33 @@ withFdSocket (Socket ref _) f = do
   touch ref
   return r
 
+-- | Socket is closed and a duplicated file descriptor is returned.
+--   The duplicated descriptor is no longer subject to the possibility
+--   of unexpectedly being closed if the socket is finalized. It is
+--   now the caller's responsibility to ultimately close the
+--   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
+    close s
+    return fd2
+
+foreign import ccall unsafe "dup"
+   c_dup :: CInt -> IO CInt
+#endif
+
 -- | Creating a socket from a file descriptor.
 mkSocket :: CInt -> IO Socket
 mkSocket fd = do

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