diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs deleted file mode 100644 --- a/benchmarks/Benchmarks.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010-2011 John Millikin --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see . - -module Main (benchmarks, main) where - -import Control.DeepSeq -import Criterion.Types -import Criterion.Config -import qualified Criterion.Main -import qualified Data.Set -import Data.Word (Word32) -import Unsafe.Coerce (unsafeCoerce) - -import DBus - -config :: Config -config = defaultConfig { cfgPerformGC = ljust True } - -serial :: Word32 -> Serial -serial = unsafeCoerce -- FIXME: should the Serial constructor be exposed to - -- clients? - -instance NFData Type - -instance NFData Signature where - rnf = rnf . signatureTypes - -instance NFData ObjectPath - -instance NFData InterfaceName - -instance NFData MemberName - -instance NFData ErrorName - -instance NFData BusName - -empty_MethodCall :: MethodCall -empty_MethodCall = MethodCall - { methodCallPath = "/" - , methodCallMember = "m" - , methodCallInterface = Nothing - , methodCallSender = Nothing - , methodCallDestination = Nothing - , methodCallFlags = Data.Set.empty - , methodCallBody = [] - } - -empty_MethodReturn :: MethodReturn -empty_MethodReturn = MethodReturn - { methodReturnSerial = serial 0 - , methodReturnSender = Nothing - , methodReturnDestination = Nothing - , methodReturnBody = [] - } - -benchMarshal :: Message msg => String -> msg -> Benchmark -benchMarshal name msg = bench name (whnf marshal msg) where - marshal = marshalMessage LittleEndian (serial 0) - -benchUnmarshal :: Message msg => String -> msg -> Benchmark -benchUnmarshal name msg = bench name (whnf unmarshalMessage bytes) where - Right bytes = marshalMessage LittleEndian (serial 0) msg - -benchmarks :: [Benchmark] -benchmarks = - [ bgroup "Types" - [ bgroup "Signature" - [ bench "parseSignature/small" (nf parseSignature "y") - , bench "parseSignature/medium" (nf parseSignature "yyyyuua(yv)") - , bench "parseSignature/large" (nf parseSignature "a{s(asiiiiasa(siiia{s(iiiiv)}))}") - ] - , bgroup "ObjectPath" - [ bench "objectPath_/small" (nf objectPath "/") - , bench "objectPath_/medium" (nf objectPath "/foo/bar") - , bench "objectPath_/large" (nf objectPath "/f0OO/b4R/baz_qux/blahblahblah") - ] - , bgroup "InterfaceName" - [ bench "interfaceName_/small" (nf interfaceName_ "f.b") - , bench "interfaceName_/medium" (nf interfaceName_ "foo.bar.baz") - , bench "interfaceName_/large" (nf interfaceName_ "f0OOO.b4R.baz_qux.blahblahblah") - ] - , bgroup "MemberName" - [ bench "memberName_/small" (nf memberName_ "f") - , bench "memberName_/medium" (nf memberName_ "FooBar") - , bench "memberName_/large" (nf memberName_ "f0OOOb4RBazQuxBlahBlahBlah") - ] - , bgroup "ErrorName" - [ bench "errorName_/small" (nf errorName_ "f.b") - , bench "errorName_/medium" (nf errorName_ "foo.bar.baz") - , bench "errorName_/large" (nf errorName_ "f0OOO.b4R.baz_qux.blahblahblah") - ] - , bgroup "BusName" - [ bench "busName_/small" (nf busName_ "f.b") - , bench "busName_/medium" (nf busName_ "foo.bar.baz") - , bench "busName_/large" (nf busName_ "f0OOO.b4R.baz-qux.blahblahblah") - ] - ] - , bgroup "Marshal" - [ benchMarshal "MethodCall/empty" empty_MethodCall - , benchMarshal "MethodReturn/empty" empty_MethodReturn - ] - , bgroup "Unmarshal" - [ benchUnmarshal "MethodCall/empty" empty_MethodCall - , benchUnmarshal "MethodReturn/empty" empty_MethodReturn - ] - ] - -main :: IO () -main = Criterion.Main.defaultMainWith config (return ()) benchmarks diff --git a/benchmarks/DBusBenchmarks.hs b/benchmarks/DBusBenchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmarks/DBusBenchmarks.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +module Main (benchmarks, main) where + +import Control.DeepSeq +import Criterion.Types +import Criterion.Config +import qualified Criterion.Main +import Data.Word (Word32) +import Unsafe.Coerce (unsafeCoerce) + +import DBus + +config :: Config +config = defaultConfig { cfgPerformGC = ljust True } + +serial :: Word32 -> Serial +serial = unsafeCoerce -- FIXME: should the Serial constructor be exposed to + -- clients? + +instance NFData Type + +instance NFData Signature where + rnf = rnf . signatureTypes + +instance NFData ObjectPath + +instance NFData InterfaceName + +instance NFData MemberName + +instance NFData ErrorName + +instance NFData BusName + +empty_MethodCall :: MethodCall +empty_MethodCall = methodCall "/" "org.i" "m" + +empty_MethodReturn :: MethodReturn +empty_MethodReturn = methodReturn (serial 0) + +benchMarshal :: Message msg => String -> msg -> Benchmark +benchMarshal name msg = bench name (whnf (marshal LittleEndian (serial 0)) msg) + +benchUnmarshal :: Message msg => String -> msg -> Benchmark +benchUnmarshal name msg = bench name (whnf unmarshal bytes) where + Right bytes = marshal LittleEndian (serial 0) msg + +benchmarks :: [Benchmark] +benchmarks = + [ bgroup "Types" + [ bgroup "Signature" + [ bench "parseSignature/small" (nf parseSignature "y") + , bench "parseSignature/medium" (nf parseSignature "yyyyuua(yv)") + , bench "parseSignature/large" (nf parseSignature "a{s(asiiiiasa(siiia{s(iiiiv)}))}") + ] + , bgroup "ObjectPath" + [ bench "objectPath_/small" (nf objectPath_ "/") + , bench "objectPath_/medium" (nf objectPath_ "/foo/bar") + , bench "objectPath_/large" (nf objectPath_ "/f0OO/b4R/baz_qux/blahblahblah") + ] + , bgroup "InterfaceName" + [ bench "interfaceName_/small" (nf interfaceName_ "f.b") + , bench "interfaceName_/medium" (nf interfaceName_ "foo.bar.baz") + , bench "interfaceName_/large" (nf interfaceName_ "f0OOO.b4R.baz_qux.blahblahblah") + ] + , bgroup "MemberName" + [ bench "memberName_/small" (nf memberName_ "f") + , bench "memberName_/medium" (nf memberName_ "FooBar") + , bench "memberName_/large" (nf memberName_ "f0OOOb4RBazQuxBlahBlahBlah") + ] + , bgroup "ErrorName" + [ bench "errorName_/small" (nf errorName_ "f.b") + , bench "errorName_/medium" (nf errorName_ "foo.bar.baz") + , bench "errorName_/large" (nf errorName_ "f0OOO.b4R.baz_qux.blahblahblah") + ] + , bgroup "BusName" + [ bench "busName_/small" (nf busName_ "f.b") + , bench "busName_/medium" (nf busName_ "foo.bar.baz") + , bench "busName_/large" (nf busName_ "f0OOO.b4R.baz-qux.blahblahblah") + ] + ] + , bgroup "Marshal" + [ benchMarshal "MethodCall/empty" empty_MethodCall + , benchMarshal "MethodReturn/empty" empty_MethodReturn + ] + , bgroup "Unmarshal" + [ benchUnmarshal "MethodCall/empty" empty_MethodCall + , benchUnmarshal "MethodReturn/empty" empty_MethodReturn + ] + ] + +main :: IO () +main = Criterion.Main.defaultMainWith config (return ()) benchmarks diff --git a/benchmarks/haskell-dbus-benchmarks.cabal b/benchmarks/haskell-dbus-benchmarks.cabal deleted file mode 100644 --- a/benchmarks/haskell-dbus-benchmarks.cabal +++ /dev/null @@ -1,16 +0,0 @@ -name: haskell-dbus-benchmarks -version: 0 -build-type: Simple -cabal-version: >= 1.6 - -executable haskell-dbus-benchmarks - main-is: Benchmarks.hs - ghc-options: -Wall -O2 -fno-warn-orphans - - build-depends: - base > 3 && < 5 - , binary - , containers - , criterion - , deepseq - , dbus diff --git a/dbus.cabal b/dbus.cabal --- a/dbus.cabal +++ b/dbus.cabal @@ -1,11 +1,11 @@ name: dbus -version: 0.10.6 +version: 0.10.7 license: GPL-3 license-file: license.txt author: John Millikin maintainer: John Millikin build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.8 category: Network, Desktop stability: experimental homepage: https://john-millikin.com/software/haskell-dbus/ @@ -66,16 +66,13 @@ extra-source-files: - benchmarks/Benchmarks.hs - benchmarks/haskell-dbus-benchmarks.cabal + benchmarks/DBusBenchmarks.hs -- examples/dbus-monitor.hs examples/export.hs examples/introspect.hs examples/list-names.hs -- - tests/data/dbus-daemon.xml - tests/haskell-dbus-tests.cabal tests/DBusTests.hs tests/DBusTests/*.hs @@ -86,26 +83,20 @@ source-repository this type: git location: https://john-millikin.com/code/haskell-dbus/ - tag: haskell-dbus_0.10.6 - -flag network-bytestring-610 - default: False - -flag network-bytestring - default: True + tag: haskell-dbus_0.10.7 library ghc-options: -Wall -O2 hs-source-dirs: lib - -- IMPORTANT: if you change these dependencies, also update them in - -- tests/ + -- IMPORTANT: keep these in sync with the test suite build-depends: base >= 4.0 && < 5.0 , bytestring >= 0.9 , cereal >= 0.3.4 && < 0.5 , containers >= 0.1 && < 0.6 , libxml-sax >= 0.7 && < 0.8 + , network >= 2.2.3 , parsec >= 2.0 && < 3.2 , random >= 1.0 && < 1.1 , text >= 0.11.1.5 @@ -114,30 +105,6 @@ , vector >= 0.7 && < 0.11 , xml-types >= 0.3 && < 0.4 - -- haskell-dbus requires Network.Socket.ByteString, which can be provided - -- by EITHER (network >= 2.2.3) or (network-bytestring >= 0.1.2). - -- - -- Flags do most of the work, but a little manual intervention is needed - -- because GHC 6.10 can't build (network >= 2.3.0.12). We want to make - -- network-bytestring the default *only* on old compilers, which requires - -- defining a separate flag with a different default value. - if impl(ghc < 6.12) - if flag(network-bytestring-610) - build-depends: - network >= 2.2.3 - else - build-depends: - network >= 2.2 && < 2.2.3 - , network-bytestring >= 0.1.2 && < 0.2 - else - if flag(network-bytestring) - build-depends: - network >= 2.2.3 - else - build-depends: - network >= 2.2 && < 2.2.3 - , network-bytestring >= 0.1.2 && < 0.2 - exposed-modules: DBus DBus.Client @@ -150,3 +117,41 @@ DBus.Message DBus.Types DBus.Wire + +test-suite dbus_tests + type: exitcode-stdio-1.0 + main-is: DBusTests.hs + hs-source-dirs: lib,tests + + build-depends: + base >= 4.0 && < 5.0 + , bytestring >= 0.9 + , cereal >= 0.3.4 && < 0.5 + , chell >= 0.3 && < 0.4 + , chell-quickcheck >= 0.2 && < 0.3 + , containers >= 0.1 && < 0.6 + , directory + , filepath + , libxml-sax >= 0.7 && < 0.8 + , network >= 2.2.3 + , parsec >= 2.0 && < 3.2 + , process >= 1.0 && < 1.2 + , QuickCheck == 2.4.* + , random >= 1.0 && < 1.1 + , text >= 0.11.1.5 + , transformers >= 0.2 && < 0.4 + , unix >= 2.2 + , vector >= 0.7 && < 0.11 + , xml-types >= 0.3 && < 0.4 + +benchmark dbus_benchmarks + type: exitcode-stdio-1.0 + main-is: DBusBenchmarks.hs + hs-source-dirs: benchmarks + ghc-options: -Wall -O2 -fno-warn-orphans + + build-depends: + dbus + , base > 4.0 && < 5.0 + , criterion >= 0.8 && < 0.9 + , deepseq diff --git a/examples/dbus-monitor.hs b/examples/dbus-monitor.hs --- a/examples/dbus-monitor.hs +++ b/examples/dbus-monitor.hs @@ -81,10 +81,10 @@ defaultFilters :: [String] defaultFilters = - [ "type='signal'" - , "type='method_call'" - , "type='method_return'" - , "type='error'" + [ "type='signal',eavesdrop=true" + , "type='method_call',eavesdrop=true" + , "type='method_return',eavesdrop=true" + , "type='error',eavesdrop=true" ] main :: IO () diff --git a/lib/DBus/Client.hs b/lib/DBus/Client.hs --- a/lib/DBus/Client.hs +++ b/lib/DBus/Client.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2009-2012 John Millikin -- @@ -70,6 +71,7 @@ -- * Receiving method calls , export + , unexport , Method , method , Reply @@ -82,8 +84,11 @@ , autoMethod -- * Signals - , listen + , SignalHandler + , addMatch + , removeMatch , emit + , listen -- ** Match rules , MatchRule @@ -132,6 +137,7 @@ import Data.Map (Map) import Data.Maybe (catMaybes, listToMaybe) import Data.Typeable (Typeable) +import Data.Unique import Data.Word (Word32) import DBus @@ -155,7 +161,7 @@ data Client = Client { clientSocket :: DBus.Socket.Socket , clientPendingCalls :: IORef (Map Serial (MVar (Either MethodError MethodReturn))) - , clientSignalHandlers :: IORef [Signal -> IO ()] + , clientSignalHandlers :: IORef (Map Unique SignalHandler) , clientObjects :: IORef (Map ObjectPath ObjectInfo) , clientThreadID :: ThreadId } @@ -179,6 +185,9 @@ type Callback = (ReceivedMessage -> IO ()) +type FormattedMatchRule = String +data SignalHandler = SignalHandler Unique FormattedMatchRule (IORef Bool) (Signal -> IO ()) + data Reply = ReplyReturn [Variant] | ReplyError ErrorName [Variant] @@ -254,7 +263,7 @@ sock <- DBus.Socket.openWith (clientSocketOptions opts) addr pendingCalls <- newIORef Data.Map.empty - signalHandlers <- newIORef [] + signalHandlers <- newIORef Data.Map.empty objects <- newIORef Data.Map.empty let threadRunner = clientThreadRunner opts @@ -301,8 +310,8 @@ forM_ (Data.Map.toList pendingCalls) $ \(k, v) -> do putMVar v (Left (methodError k errorDisconnected)) - atomicModifyIORef (clientSignalHandlers client) (\_ -> ([], ())) - atomicModifyIORef (clientObjects client) (\_ -> (Data.Map.empty, ())) + atomicWriteIORef (clientSignalHandlers client) Data.Map.empty + atomicWriteIORef (clientObjects client) Data.Map.empty DBus.Socket.close (clientSocket client) @@ -325,7 +334,7 @@ go (ReceivedMethodError _ msg) = dispatchReply (methodErrorSerial msg) (Left msg) go (ReceivedSignal _ msg) = do handlers <- readIORef (clientSignalHandlers client) - forM_ handlers (\h -> forkIO (h msg) >> return ()) + forM_ (Data.Map.toAscList handlers) (\(_, SignalHandler _ _ _ h) -> forkIO (h msg) >> return ()) go received@(ReceivedMethodCall serial msg) = do objects <- readIORef (clientObjects client) let sender = methodCallSender msg @@ -492,7 +501,7 @@ send_ client msg io = do result <- Control.Exception.try (DBus.Socket.send (clientSocket client) msg io) case result of - Right serial -> return serial + Right x -> return x Left err -> throwIO (clientError (DBus.Socket.socketErrorMessage err)) { clientErrorFatal = DBus.Socket.socketErrorFatal err } @@ -509,17 +518,15 @@ { methodCallReplyExpected = True } mvar <- newEmptyMVar - send_ client safeMsg (\serial -> do - let ref = clientPendingCalls client - - -- If the mvar is finalized, remove its serial from the pending - -- call map. This allows calls to be canceled, by using - -- something like 'timeout' to make 'call' return early, and - -- having the finalizer clear out the map. - addMVarFinalizer mvar (atomicModifyIORef ref (\p -> (Data.Map.delete serial p, ()))) - - atomicModifyIORef ref (\p -> (Data.Map.insert serial mvar p, ()))) - takeMVar mvar + let ref = clientPendingCalls client + serial <- send_ client safeMsg (\serial -> atomicModifyIORef ref (\p -> (Data.Map.insert serial mvar p, serial))) + + -- At this point, we wait for the reply to arrive. The user may cancel + -- a pending call by sending this thread an exception via something + -- like 'timeout'; in that case, we want to clean up the pending call. + Control.Exception.onException + (takeMVar mvar) + (atomicModifyIORef_ ref (Data.Map.delete serial)) -- | Send a method call to the bus, and wait for the response. -- @@ -555,22 +562,46 @@ -- A received signal might be processed by more than one callback at a time. -- Callbacks each run in their own thread. -- +-- The returned 'SignalHandler' can be passed to 'removeMatch' +-- to stop handling this signal. +-- -- Throws a 'ClientError' if the match rule couldn't be added to the bus. -listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO () -listen client rule io = do - let handler msg = when (checkMatchRule rule msg) (io msg) - +addMatch :: Client -> MatchRule -> (Signal -> IO ()) -> IO SignalHandler +addMatch client rule io = do let formatted = case formatMatchRule rule of "" -> "type='signal'" x -> "type='signal'," ++ x - atomicModifyIORef (clientSignalHandlers client) (\hs -> (handler : hs, ())) + handlerId <- newUnique + registered <- newIORef True + let handler = SignalHandler handlerId formatted registered (\msg -> when (checkMatchRule rule msg) (io msg)) + + atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.insert handlerId handler hs, ())) _ <- call_ client (methodCall dbusPath dbusInterface "AddMatch") { methodCallDestination = Just dbusName , methodCallBody = [toVariant formatted] } - return () + return handler +-- | Request that the bus stop forwarding signals for the given handler. +-- +-- Throws a 'ClientError' if the match rule couldn't be removed from the bus. +removeMatch :: Client -> SignalHandler -> IO () +removeMatch client (SignalHandler handlerId formatted registered _) = do + shouldUnregister <- atomicModifyIORef registered (\wasRegistered -> (False, wasRegistered)) + when shouldUnregister $ do + atomicModifyIORef (clientSignalHandlers client) (\hs -> (Data.Map.delete handlerId hs, ())) + _ <- call_ client (methodCall dbusPath dbusInterface "RemoveMatch") + { methodCallDestination = Just dbusName + , methodCallBody = [toVariant formatted] + } + return () + +-- | Equivalent to 'addMatch', but does not return the added 'SignalHandler'. +listen :: Client -> MatchRule -> (Signal -> IO ()) -> IO () +listen client rule io = addMatch client rule io >> return () +{-# DEPRECATED listen "Prefer DBus.Client.addMatch in new code." #-} + -- | Emit the signal on the bus. -- -- Throws a 'ClientError' if the signal message couldn't be sent. @@ -731,6 +762,12 @@ let Just obj = Data.Map.lookup path objects return (introspect path obj) +-- | Revokes the export of the given 'ObjectPath'. This will remove all +-- interfaces and methods associated with the path. +unexport :: Client -> ObjectPath -> IO () +unexport client path = atomicModifyIORef (clientObjects client) deleteObject where + deleteObject objs = (Data.Map.delete path objs, ()) + findMethod :: Map ObjectPath ObjectInfo -> MethodCall -> Either ErrorName Callback findMethod objects msg = case Data.Map.lookup (methodCallPath msg) objects of Nothing -> Left errorUnknownObject @@ -909,3 +946,11 @@ interfaceIntrospectable :: InterfaceName interfaceIntrospectable = interfaceName_ "org.freedesktop.DBus.Introspectable" + +atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () +atomicModifyIORef_ ref fn = atomicModifyIORef ref (\x -> (fn x, ())) + +#if !MIN_VERSION_base(4,6,0) +atomicWriteIORef :: IORef a -> a -> IO () +atomicWriteIORef ref x = atomicModifyIORef ref (\_ -> (x, ())) +#endif diff --git a/lib/DBus/Transport.hs b/lib/DBus/Transport.hs --- a/lib/DBus/Transport.hs +++ b/lib/DBus/Transport.hs @@ -228,12 +228,18 @@ connect sock (SockAddrUnix p) return (SocketTransport (Just transportAddr) sock)) +tcpHostname :: Maybe String -> Either a Network.Socket.Family -> String +tcpHostname (Just host) _ = host +tcpHostname Nothing (Right AF_INET) = "127.0.0.1" +tcpHostname Nothing (Right AF_INET6) = "::1" +tcpHostname _ _ = "localhost" + openTcp :: Address -> IO SocketTransport openTcp transportAddr = go where params = addressParameters transportAddr param key = Map.lookup key params - hostname = maybe "localhost" id (param "host") + hostname = tcpHostname (param "host") getFamily unknownFamily x = "Unknown socket family for TCP transport: " ++ show x getFamily = case param "family" of Just "ipv4" -> Right AF_INET @@ -356,9 +362,7 @@ paramBind = case param "bind" of Just "*" -> Nothing Just x -> Just x - Nothing -> case param "host" of - Just x -> Just x - Nothing -> Just "localhost" + Nothing -> Just (tcpHostname (param "host") getFamily) getAddresses family_ = getAddrInfo (Just (defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE] diff --git a/tests/DBusTests/Client.hs b/tests/DBusTests/Client.hs --- a/tests/DBusTests/Client.hs +++ b/tests/DBusTests/Client.hs @@ -38,7 +38,7 @@ test_ReleaseName test_Call test_CallNoReply - test_Listen + test_AddMatch test_AutoMethod test_ExportIntrospection @@ -301,8 +301,8 @@ }) methodReturn -test_Listen :: Test -test_Listen = assertions "listen" $ do +test_AddMatch :: Test +test_AddMatch = assertions "addMatch" $ do (sock, client) <- startConnectedClient let matchRule = DBus.Client.matchAny @@ -325,7 +325,7 @@ -- add a listener for the given signal stubMethodCall sock - (DBus.Client.listen client matchRule (putMVar signalVar)) + (DBus.Client.addMatch client matchRule (putMVar signalVar)) requestCall methodReturn diff --git a/tests/DBusTests/Integration.hs b/tests/DBusTests/Integration.hs --- a/tests/DBusTests/Integration.hs +++ b/tests/DBusTests/Integration.hs @@ -22,15 +22,15 @@ import Control.Exception (finally) import Control.Monad.IO.Class (liftIO) +import System.Directory (removeFile) import System.Exit -import System.IO (hGetLine) +import System.IO (hGetLine, writeFile) import System.Process import DBus import DBus.Socket import DBus.Client - -import Paths_haskell_dbus_tests (getDataFileName) +import DBusTests.Util (getTempPath) test_Integration :: Suite test_Integration = suite "integration" @@ -91,13 +91,32 @@ liftIO (disconnect clientA) liftIO (disconnect clientB) +configFileContent :: String +configFileContent = "\ +\\ +\\ +\ session\ +\ \ +\ unix:tmpdir=/tmp\ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\" + withDaemon :: String -> (Address -> Assertions ()) -> Test withDaemon name io = test name $ \opts -> do (versionExit, _, _) <- readProcessWithExitCode "dbus-daemon" ["--version"] "" case versionExit of ExitFailure _ -> return TestSkipped ExitSuccess -> do - configFilePath <- getDataFileName "data/dbus-daemon.xml" + configFilePath <- liftIO getTempPath + writeFile configFilePath configFileContent daemon <- createProcess (proc "dbus-daemon" ["--config-file=" ++ configFilePath, "--print-address"]) { std_out = CreatePipe , close_fds = True @@ -112,4 +131,5 @@ (do terminateProcess daemonProc _ <- waitForProcess daemonProc + removeFile configFilePath return ()) diff --git a/tests/DBusTests/Util.hs b/tests/DBusTests/Util.hs --- a/tests/DBusTests/Util.hs +++ b/tests/DBusTests/Util.hs @@ -153,7 +153,7 @@ sockPort <- NS.socketPort sock let Just addr = address "tcp" (Map.fromList [ ("family", "ipv6") - , ("host", "localhost") + , ("host", "::1") , ("port", show (toInteger sockPort)) ]) return (addr, sock) diff --git a/tests/data/dbus-daemon.xml b/tests/data/dbus-daemon.xml deleted file mode 100644 --- a/tests/data/dbus-daemon.xml +++ /dev/null @@ -1,15 +0,0 @@ - - - session - - unix:tmpdir=/tmp - - - - - - - - - diff --git a/tests/haskell-dbus-tests.cabal b/tests/haskell-dbus-tests.cabal deleted file mode 100644 --- a/tests/haskell-dbus-tests.cabal +++ /dev/null @@ -1,63 +0,0 @@ -name: haskell-dbus-tests -version: 0 -build-type: Simple -cabal-version: >= 1.6 - -data-files: - data/dbus-daemon.xml - -flag coverage - default: False - manual: True - -flag network-bytestring-610 - default: False - -flag network-bytestring - default: True - -executable haskell-dbus-tests - main-is: DBusTests.hs - ghc-options: -Wall -fno-warn-orphans - hs-source-dirs: ../lib,. - - if flag(coverage) - ghc-options: -fhpc - - build-depends: - base > 4.0 && < 5.0 - , bytestring >= 0.9 - , cereal >= 0.3.4 && < 0.4 - , chell >= 0.3 && < 0.4 - , chell-quickcheck >= 0.2 && < 0.3 - , containers >= 0.1 && < 0.6 - , directory - , filepath - , libxml-sax >= 0.7 && < 0.8 - , parsec >= 2.0 && < 3.2 - , process >= 1.0 && < 1.2 - , QuickCheck == 2.4.* - , random >= 1.0 && < 1.1 - , text >= 0.11.1.5 && < 0.12 - , transformers >= 0.2 && < 0.4 - , unix >= 2.2 && < 2.7 - , vector >= 0.7 && < 0.11 - , xml-types >= 0.3 && < 0.4 - - -- see comments in dbus.cabal - if impl(ghc < 6.12) - if flag(network-bytestring-610) && false - build-depends: - network >= 2.2.3 && < 2.4 - else - build-depends: - network >= 2.2 && < 2.2.3 - , network-bytestring >= 0.1.2 && < 0.2 - else - if flag(network-bytestring) - build-depends: - network >= 2.2.3 && < 2.4 - else - build-depends: - network >= 2.2 && < 2.2.3 - , network-bytestring >= 0.1.2 && < 0.2