diff --git a/CHANGELOG.md b/CHANGELOG.md index f41b8c7a..2109d8a8 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/Network/Socket/Unix.hsc b/Network/Socket/Unix.hsc index 2562f117..70372271 100644 --- a/Network/Socket/Unix.hsc +++ b/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 diff --git a/network.cabal b/network.cabal index 675775c5..4e63d8dc 100644 --- a/network.cabal +++ b/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 diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs index 068b7353..9c01adff 100644 --- a/tests/Network/SocketSpec.hs +++ b/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