Work around historical behavioural oddity with UNIX domain sockets

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,

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

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