dbus 0.10.6 → 0.10.7
raw patch · 12 files changed
+264/−299 lines, 12 filesdep +QuickCheckdep +chelldep +chell-quickcheckdep −network-bytestringdep ~basedep ~network
Dependencies added: QuickCheck, chell, chell-quickcheck, criterion, dbus, deepseq, directory, filepath, process
Dependencies removed: network-bytestring
Dependency ranges changed: base, network
Files
- benchmarks/Benchmarks.hs +0/−124
- benchmarks/DBusBenchmarks.hs +109/−0
- benchmarks/haskell-dbus-benchmarks.cabal +0/−16
- dbus.cabal +44/−39
- examples/dbus-monitor.hs +4/−4
- lib/DBus/Client.hs +70/−25
- lib/DBus/Transport.hs +8/−4
- tests/DBusTests/Client.hs +4/−4
- tests/DBusTests/Integration.hs +24/−4
- tests/DBusTests/Util.hs +1/−1
- tests/data/dbus-daemon.xml +0/−15
- tests/haskell-dbus-tests.cabal +0/−63
− benchmarks/Benchmarks.hs
@@ -1,124 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>--- --- 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 <http://www.gnu.org/licenses/>.--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
+ benchmarks/DBusBenchmarks.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>+-- +-- 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 <http://www.gnu.org/licenses/>.++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
− benchmarks/haskell-dbus-benchmarks.cabal
@@ -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
dbus.cabal view
@@ -1,11 +1,11 @@ name: dbus-version: 0.10.6+version: 0.10.7 license: GPL-3 license-file: license.txt author: John Millikin <jmillikin@gmail.com> maintainer: John Millikin <jmillikin@gmail.com> 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
examples/dbus-monitor.hs view
@@ -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 ()
lib/DBus/Client.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-} -- Copyright (C) 2009-2012 John Millikin <jmillikin@gmail.com> --@@ -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
lib/DBus/Transport.hs view
@@ -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]
tests/DBusTests/Client.hs view
@@ -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
tests/DBusTests/Integration.hs view
@@ -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 = "\+\<!DOCTYPE busconfig PUBLIC \"-//freedesktop//DTD D-Bus Bus Configuration 1.0//EN\"\+\ \"http://www.freedesktop.org/standards/dbus/1.0/busconfig.dtd\">\+\<busconfig>\+\ <type>session</type>\+\ <keep_umask/>\+\ <listen>unix:tmpdir=/tmp</listen>\+\ <policy context=\"default\">\+\ <!-- Allow everything to be sent -->\+\ <allow send_destination=\"*\" eavesdrop=\"true\"/>\+\ <!-- Allow everything to be received -->\+\ <allow eavesdrop=\"true\"/>\+\ <!-- Allow anyone to own anything -->\+\ <allow own=\"*\"/>\+\ </policy>\+\</busconfig>"+ 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 ())
tests/DBusTests/Util.hs view
@@ -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)
− tests/data/dbus-daemon.xml
@@ -1,15 +0,0 @@-<!DOCTYPE busconfig PUBLIC "-//freedesktop//DTD D-Bus Bus Configuration 1.0//EN"- "http://www.freedesktop.org/standards/dbus/1.0/busconfig.dtd">-<busconfig>- <type>session</type>- <keep_umask/>- <listen>unix:tmpdir=/tmp</listen>- <policy context="default">- <!-- Allow everything to be sent -->- <allow send_destination="*" eavesdrop="true"/>- <!-- Allow everything to be received -->- <allow eavesdrop="true"/>- <!-- Allow anyone to own anything -->- <allow own="*"/>- </policy>-</busconfig>
− tests/haskell-dbus-tests.cabal
@@ -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