diff --git a/dbus.cabal b/dbus.cabal --- a/dbus.cabal +++ b/dbus.cabal @@ -1,5 +1,5 @@ name: dbus -version: 0.10.2 +version: 0.10.3 license: GPL-3 license-file: license.txt author: John Millikin @@ -86,7 +86,7 @@ source-repository this type: bazaar location: https://john-millikin.com/branches/haskell-dbus/0.10/ - tag: haskell-dbus_0.10.1 + tag: haskell-dbus_0.10.3 flag network-bytestring-610 default: False diff --git a/lib/DBus/Transport.hs b/lib/DBus/Transport.hs --- a/lib/DBus/Transport.hs +++ b/lib/DBus/Transport.hs @@ -221,10 +221,12 @@ Left err -> throwIO (transportError err) { transportErrorAddress = Just transportAddr } - Right p -> catchIOException (Just transportAddr) $ do - sock <- socket AF_UNIX Stream defaultProtocol - connect sock (SockAddrUnix p) - return (SocketTransport (Just transportAddr) sock) + Right p -> catchIOException (Just transportAddr) $ bracketOnError + (socket AF_UNIX Stream defaultProtocol) + sClose + (\sock -> do + connect sock (SockAddrUnix p) + return (SocketTransport (Just transportAddr) sock)) openTcp :: Address -> IO SocketTransport openTcp transportAddr = go where @@ -324,11 +326,13 @@ Left err -> throwIO (transportError err) { transportErrorAddress = Just origAddr } - Right (addr, p) -> catchIOException (Just addr) $ do - sock <- socket AF_UNIX Stream defaultProtocol - bindSocket sock (SockAddrUnix p) - Network.Socket.listen sock (socketTransportOptionBacklog opts) - return (addr, sock) + Right (addr, p) -> catchIOException (Just origAddr) $ bracketOnError + (socket AF_UNIX Stream defaultProtocol) + sClose + (\sock -> do + bindSocket sock (SockAddrUnix p) + Network.Socket.listen sock (socketTransportOptionBacklog opts) + return (addr, sock)) listenTcp :: UUID -> Address -> TransportOptions SocketTransport -> IO (Address, Socket) listenTcp uuid origAddr opts = go where @@ -398,20 +402,16 @@ } Right family_ -> catchIOException (Just origAddr) $ do sockAddrs <- getAddresses family_ - - sock <- (bracketOnError - (do - sock <- socket family_ Stream defaultProtocol - setSocketOption sock ReuseAddr 1 - return sock) + bracketOnError + (socket family_ Stream defaultProtocol) sClose (\sock -> do + setSocketOption sock ReuseAddr 1 bindAddrs sock (map (setPort port) sockAddrs) - return sock)) - - Network.Socket.listen sock (socketTransportOptionBacklog opts) - sockPort <- socketPort sock - return (sockAddr sockPort, sock) + + Network.Socket.listen sock (socketTransportOptionBacklog opts) + sockPort <- socketPort sock + return (sockAddr sockPort, sock)) catchIOException :: Maybe Address -> IO a -> IO a catchIOException addr io = do diff --git a/tests/DBusTests/Transport.hs b/tests/DBusTests/Transport.hs --- a/tests/DBusTests/Transport.hs +++ b/tests/DBusTests/Transport.hs @@ -83,28 +83,45 @@ (addr, networkSocket) <- listenRandomUnixPath afterTest (N.sClose networkSocket) + fdcountBefore <- countFileDescriptors + t <- liftIO (transportOpen socketTransportOptions addr) - afterTest (transportClose t) + liftIO (transportClose t) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenUnix_Abstract :: Test test_OpenUnix_Abstract = assertions "abstract" $ do (addr, networkSocket) <- listenRandomUnixAbstract afterTest (N.sClose networkSocket) + fdcountBefore <- countFileDescriptors + t <- liftIO (transportOpen socketTransportOptions addr) - afterTest (transportClose t) + liftIO (transportClose t) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenUnix_TooFew :: Test test_OpenUnix_TooFew = assertions "too-few" $ do + fdcountBefore <- countFileDescriptors + let Just addr = address "unix" Map.empty $assert $ throwsEq ((transportError "One of 'path' or 'abstract' must be specified for the 'unix' transport.") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenUnix_TooMany :: Test test_OpenUnix_TooMany = assertions "too-many" $ do + fdcountBefore <- countFileDescriptors + let Just addr = address "unix" (Map.fromList [ ("path", "foo") , ("abstract", "bar") @@ -114,9 +131,14 @@ { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenUnix_NotListening :: Test test_OpenUnix_NotListening = assertions "not-listening" $ do + fdcountBefore <- countFileDescriptors + (addr, networkSocket) <- listenRandomUnixAbstract liftIO (NS.sClose networkSocket) $assert $ throwsEq @@ -124,6 +146,9 @@ { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenTcp :: Suite test_OpenTcp = suite "tcp" @@ -140,19 +165,31 @@ (addr, networkSocket) <- listenRandomIPv4 afterTest (N.sClose networkSocket) + fdcountBefore <- countFileDescriptors + t <- liftIO (transportOpen socketTransportOptions addr) - afterTest (transportClose t) + liftIO (transportClose t) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenTcp_IPv6 :: Test test_OpenTcp_IPv6 = assertions "ipv6" $ do (addr, networkSocket) <- listenRandomIPv6 afterTest (N.sClose networkSocket) + fdcountBefore <- countFileDescriptors + t <- liftIO (transportOpen socketTransportOptions addr) - afterTest (transportClose t) + liftIO (transportClose t) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenTcp_Unknown :: Test test_OpenTcp_Unknown = assertions "unknown-family" $ do + fdcountBefore <- countFileDescriptors + let Just addr = address "tcp" (Map.fromList [ ("family", "noexist") , ("port", "1234") @@ -162,9 +199,14 @@ { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenTcp_NoPort :: Test test_OpenTcp_NoPort = assertions "no-port" $ do + fdcountBefore <- countFileDescriptors + let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") ]) @@ -173,9 +215,14 @@ { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenTcp_InvalidPort :: Test test_OpenTcp_InvalidPort = assertions "invalid-port" $ do + fdcountBefore <- countFileDescriptors + let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "123456") @@ -185,9 +232,14 @@ { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenTcp_NoUsableAddresses :: Test test_OpenTcp_NoUsableAddresses = assertions "no-usable-addresses" $ do + fdcountBefore <- countFileDescriptors + let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "1234") @@ -199,9 +251,14 @@ , transportErrorAddress err == Just addr ]) (transportOpen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_OpenTcp_NotListening :: Test test_OpenTcp_NotListening = assertions "too-many" $ do + fdcountBefore <- countFileDescriptors + (addr, networkSocket) <- listenRandomIPv4 liftIO (NS.sClose networkSocket) $assert $ throwsEq @@ -209,6 +266,9 @@ { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_TransportSendReceive :: Test test_TransportSendReceive = assertions "send-receive" $ do @@ -278,6 +338,7 @@ test_ListenUnix_Tmpdir test_ListenUnix_TooFew test_ListenUnix_TooMany + test_ListenUnix_InvalidBind test_ListenUnix_Path :: Test test_ListenUnix_Path = assertions "path" $ do @@ -342,6 +403,22 @@ }) (transportListen socketTransportOptions addr) +test_ListenUnix_InvalidBind :: Test +test_ListenUnix_InvalidBind = assertions "invalid-bind" $ do + fdcountBefore <- countFileDescriptors + + let Just addr = address "unix" (Map.fromList + [ ("path", "/") + ]) + $assert $ throwsEq + ((transportError "bind: resource busy (Address already in use)") + { transportErrorAddress = Just addr + }) + (transportListen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) + test_ListenTcp :: Suite test_ListenTcp = suite "tcp" test_ListenTcp_IPv4 @@ -400,6 +477,8 @@ test_ListenTcp_InvalidBind :: Test test_ListenTcp_InvalidBind = assertions "invalid-bind" $ do + fdcountBefore <- countFileDescriptors + let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "1") @@ -409,6 +488,9 @@ { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) + + fdcountAfter <- countFileDescriptors + $assert (equal fdcountBefore fdcountAfter) test_AcceptSocket :: Test test_AcceptSocket = assertions "socket" $ do diff --git a/tests/DBusTests/Util.hs b/tests/DBusTests/Util.hs --- a/tests/DBusTests/Util.hs +++ b/tests/DBusTests/Util.hs @@ -27,7 +27,9 @@ , listenRandomIPv6 , noIPv6 , forkVar + , withEnv + , countFileDescriptors , dropWhileEnd @@ -38,7 +40,7 @@ ) where import Control.Concurrent -import Control.Exception (IOException, try, bracket_) +import Control.Exception (IOException, try, bracket, bracket_) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bits ((.&.)) import qualified Data.ByteString @@ -50,7 +52,7 @@ import qualified Network as N import qualified Network.Socket as NS import System.Directory (getTemporaryDirectory, removeFile) -import qualified System.Posix.Env +import qualified System.Posix as Posix import System.FilePath (()) import Test.Chell @@ -172,10 +174,23 @@ withEnv :: MonadIO m => String -> Maybe String -> IO a -> m a withEnv name value io = liftIO $ do let set val = case val of - Just x -> System.Posix.Env.setEnv name x True - Nothing -> System.Posix.Env.unsetEnv name - old <- System.Posix.Env.getEnv name + Just x -> Posix.setEnv name x True + Nothing -> Posix.unsetEnv name + old <- Posix.getEnv name bracket_ (set value) (set old) io + +countFileDescriptors :: MonadIO m => m Int +countFileDescriptors = liftIO io where + io = do + pid <- Posix.getProcessID + let fdDir = "/proc/" ++ show pid ++ "/fd" + bracket (Posix.openDirStream fdDir) Posix.closeDirStream countDirEntries + countDirEntries dir = loop 0 where + loop n = do + name <- Posix.readDirStream dir + if null name + then return n + else loop (n + 1) instance (Arbitrary a, Ord a) => Arbitrary (Data.Set.Set a) where arbitrary = fmap Data.Set.fromList arbitrary