Emulate socketPair with TCP over loopback on Windows

CHANGELOG.md

@@ -17,6 +17,8 @@
   [#626](https://github.com/haskell/network/pull/626)
 * WINIO: fixing a spurious EOF when a recv completes synchronously.
   [#626](https://github.com/haskell/network/pull/626)
+* Emulate socketPair with TCP over loopback on Windows
+  [#630](https://github.com/haskell/network/pull/630)
 
 ## Version 3.2.9.0
 

Network/Socket/Unix.hsc

@@ -22,11 +22,11 @@ import Network.Socket.Types
 import System.Posix.Types (Fd(..))
 
 #if defined(mingw32_HOST_OS)
+import qualified Control.Exception as E
+import Network.Socket.Name (getSocketName)
+import Network.Socket.Options
 import Network.Socket.Syscall
 import Network.Socket.Win32.Cmsg
-import System.Directory
-import System.IO
-import System.IO.Temp
 #else
 import Foreign.Marshal.Array (peekArray)
 import Network.Socket.Internal
@@ -156,26 +156,35 @@ recvFd s = allocaBytes dummyBufSize $ \buf -> do
     dummyBufSize = 16
 
 -- | Build a pair of connected socket objects.
---   On Windows, this function emulates socketpair() using
---   'AF_UNIX' and a temporary file will remain.
+--   On Windows, this function emulates socketpair() with a TCP connection
+--   over the loopback interface, whatever the arguments are: there an
+--   'AF_UNIX' recv may miss the peer's close and wait for ever.
 socketPair :: Family              -- Family Name (usually AF_UNIX)
            -> SocketType          -- Socket Type (usually Stream)
            -> ProtocolNumber      -- Protocol Number
            -> IO (Socket, Socket) -- unnamed and connected.
 #if defined(mingw32_HOST_OS)
-socketPair _ _ _ = withSystemTempFile "temp-for-pair" $ \file hdl -> do
-    hClose hdl
-    removeFile file
-    listenSock <- socket AF_UNIX Stream defaultProtocol
-    bind listenSock $ SockAddrUnix file
-    listen listenSock 10
-    clientSock <- socket AF_UNIX Stream defaultProtocol
-    connect clientSock $ SockAddrUnix file
-    (serverSock, _ :: SockAddr) <- accept listenSock
-    close listenSock
-    withFdSocket clientSock setNonBlockIfNeeded
-    withFdSocket serverSock setNonBlockIfNeeded
-    return (clientSock, serverSock)
+socketPair _ _ _ =
+    E.bracket (socket AF_INET Stream defaultProtocol) close $ \listenSock -> do
+        bind listenSock $ SockAddrInet 0 $ tupleToHostAddress (127, 0, 0, 1)
+        listen listenSock 10
+        addr :: SockAddr <- getSocketName listenSock
+        E.bracketOnError (socket AF_INET Stream defaultProtocol) close $ \clientSock -> do
+            connect clientSock addr
+            me :: SockAddr <- getSocketName clientSock
+            serverSock <- acceptFrom listenSock me
+            mapM_ prepare [clientSock, serverSock]
+            return (clientSock, serverSock)
+  where
+    -- Another process may connect to the port first; it is not our peer.
+    acceptFrom listenSock me = do
+        (sock, peer) <- accept listenSock
+        if peer == me
+            then return sock
+            else close sock >> acceptFrom listenSock me
+    prepare sock = do
+        setSocketOption sock NoDelay 1
+        withFdSocket sock setNonBlockIfNeeded
 #else
 socketPair family stype protocol =
     allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do

network.cabal

@@ -171,8 +171,6 @@ library
             iphlpapi
             mswsock
 
-        build-depends:   temporary
-
         if impl(ghc >=7.10 && <9.0)
             cpp-options: -D_WIN32_WINNT=0x0600
             cc-options:  -D_WIN32_WINNT=0x0600

tests/Network/SocketSpec.hs

@@ -4,7 +4,7 @@
 module Network.SocketSpec (main, spec) where
 
 import Control.Concurrent (threadDelay, forkIO)
-import Control.Concurrent.MVar (readMVar)
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar, takeMVar)
 import Control.Monad
 import Data.List (nub)
 import Data.Maybe (fromJust)
@@ -16,6 +16,7 @@ import System.IO.Error (tryIOError)
 import System.IO.Temp (withSystemTempDirectory)
 import System.Mem (performGC)
 import System.Posix.Types (Fd(..))
+import System.Timeout (timeout)
 
 import Test.Hspec
 import Test.QuickCheck
@@ -161,6 +162,25 @@ spec = do
             -- check if an exception is not thrown.
             isSupportedSockAddr addr `shouldBe` True
 
+    describe "socketPair" $ do
+        it "can send and recieve bi-directionally" $ do
+            (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol
+            void $ send s1 testMsg
+            recv s2 1024 `shouldReturn` testMsg
+            void $ send s2 testMsg
+            recv s1 1024 `shouldReturn` testMsg
+
+        -- Windows' AF_UNIX pair now and then missed a close racing the
+        -- recv (seen in C and the non-threaded RTS, rarely here).
+        it "tells a waiting recv that the peer has closed" $
+            replicateM_ 100 $ do
+                (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol
+                got <- newEmptyMVar
+                _ <- forkIO $ recv s2 1024 >>= putMVar got
+                _ <- forkIO $ close s1
+                timeout 5000000 (takeMVar got) `shouldReturn` Just ""
+                close s2
+
 #if !defined(mingw32_HOST_OS)
     when isUnixDomainSocketAvailable $ do
         context "unix sockets" $ do
@@ -192,14 +212,6 @@ spec = do
 #endif
 
 #if !defined(mingw32_HOST_OS)
-            describe "socketPair" $ do
-                it "can send and recieve bi-directionally" $ do
-                    (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol
-                    void $ send s1 testMsg
-                    recv s2 1024 `shouldReturn` testMsg
-                    void $ send s2 testMsg
-                    recv s1 1024 `shouldReturn` testMsg
-
             describe "sendFd/recvFd" $ do
                 it "can send and recieve a file descriptor" $ do
                     (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol