diff --git a/Network/Socket/SockAddr.hs b/Network/Socket/SockAddr.hs index 8468e2a9..49f4c224 100644 --- a/Network/Socket/SockAddr.hs +++ b/Network/Socket/SockAddr.hs @@ -11,6 +11,10 @@ module Network.Socket.SockAddr ( , recvBufMsg ) where +import Control.Exception (try, throwIO, IOException) +import System.Directory (removeFile) +import System.IO.Error (isAlreadyInUseError, isDoesNotExistError) + import qualified Network.Socket.Buffer as G import qualified Network.Socket.Name as G import qualified Network.Socket.Syscall as G @@ -41,7 +45,25 @@ connect = G.connect -- 'defaultPort' is passed then the system assigns the next available -- use port. bind :: Socket -> SockAddr -> IO () -bind = G.bind +bind s a = case a of + SockAddrUnix p -> do + -- gracefully handle the fact that UNIX systems don't clean up closed UNIX + -- domain sockets, inspired by https://stackoverflow.com/a/13719866 + res <- try (G.bind s a) + case res of + Right () -> return () + Left e | not (isAlreadyInUseError e) -> throwIO (e :: IOException) + Left e | otherwise -> do + -- socket might be in use, try to connect + res2 <- try (G.connect s a) + case res2 of + Right () -> close s >> throwIO e + Left e2 | not (isDoesNotExistError e2) -> throwIO (e2 :: IOException) + _ -> do + -- socket not actually in use, remove it and retry bind + removeFile p + G.bind s a + _ -> G.bind s a -- | Accept a connection. The socket must be bound to an address and -- listening for connections. The return value is a pair @(conn, diff --git a/network.cabal b/network.cabal index c298134f..6d1888c8 100644 --- a/network.cabal +++ b/network.cabal @@ -83,7 +83,8 @@ library build-depends: base >= 4.7 && < 5, bytestring == 0.10.*, - deepseq + deepseq, + directory include-dirs: include includes: HsNet.h HsNetDef.h alignment.h win32defs.h @@ -141,6 +142,7 @@ test-suite spec directory, HUnit, network, + temporary, hspec >= 2.6 test-suite doctests diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs index fd8abe94..fd13a0d4 100644 --- a/tests/Network/SocketSpec.hs +++ b/tests/Network/SocketSpec.hs @@ -11,6 +11,8 @@ import Network.Socket import Network.Socket.ByteString import Network.Test.Common import System.Mem (performGC) +import System.IO.Error (tryIOError, isAlreadyInUseError) +import System.IO.Temp (withSystemTempDirectory) import Test.Hspec @@ -63,6 +65,36 @@ spec = do sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) bind sock (addrAddress addr) `shouldThrow` anyIOException + it "successfully binds to a unix socket, twice" $ do + withSystemTempDirectory "haskell-network" $ \path -> do + let sfile = path ++ "/socket-file" + let addr = SockAddrUnix sfile + when (isSupportedSockAddr addr) $ do + sock0 <- socket AF_UNIX Stream defaultProtocol + bind sock0 addr + listen sock0 1 + + sock1 <- socket AF_UNIX Stream defaultProtocol + tryIOError (bind sock1 addr) >>= \o -> case o of + Right () -> error "bind should have failed but succeeded" + Left e | not (isAlreadyInUseError e) -> ioError e + _ -> return () + + close sock0 + + -- Unix systems tend to leave the file existing, which is + -- why our `bind` does its workaround. however if any + -- system in the future does fix this issue, we don't want + -- this test to fail, since that would defeat the purpose + -- of our workaround. but you can uncomment the below lines + -- if you want to play with this on your own system. + --import System.Directory (doesPathExist) + --ex <- doesPathExist sfile + --unless ex $ error "socket file was deleted unexpectedly" + + sock2 <- socket AF_UNIX Stream defaultProtocol + bind sock2 addr + describe "UserTimeout" $ do it "can be set" $ do when (isSupportedSocketOption UserTimeout) $ do