diff --git a/benchmarks/DBusBenchmarks.hs b/benchmarks/DBusBenchmarks.hs --- a/benchmarks/DBusBenchmarks.hs +++ b/benchmarks/DBusBenchmarks.hs @@ -17,37 +17,17 @@ module Main (benchmarks, main) where -import Control.DeepSeq -import Criterion.Types -import Criterion.Config +import Criterion.Types +import Data.Word (Word32) +import Unsafe.Coerce (unsafeCoerce) import qualified Criterion.Main -import Data.Word (Word32) -import Unsafe.Coerce (unsafeCoerce) -import DBus - -config :: Config -config = defaultConfig { cfgPerformGC = ljust True } +import DBus 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" @@ -106,4 +86,4 @@ ] main :: IO () -main = Criterion.Main.defaultMainWith config (return ()) benchmarks +main = Criterion.Main.defaultMain benchmarks diff --git a/dbus.cabal b/dbus.cabal --- a/dbus.cabal +++ b/dbus.cabal @@ -1,9 +1,9 @@ name: dbus -version: 0.10.13 +version: 0.10.14 license: GPL-3 license-file: license.txt author: John Millikin -maintainer: Andrey Sverdlichenko , John Millikin +maintainer: Andrey Sverdlichenko build-type: Simple cabal-version: >= 1.8 category: Network, Desktop @@ -83,6 +83,7 @@ , bytestring , cereal , containers + , deepseq , libxml-sax , network , parsec @@ -108,16 +109,16 @@ type: exitcode-stdio-1.0 main-is: DBusTests.hs hs-source-dirs: tests + ghc-options: -W -Wall build-depends: dbus , base , bytestring , cereal - , chell - , chell-quickcheck , containers , directory + , extra , filepath , libxml-sax , network @@ -125,6 +126,10 @@ , process , QuickCheck , random + , resourcet + , tasty + , tasty-hunit + , tasty-quickcheck , text , transformers , unix @@ -160,4 +165,3 @@ dbus , base , criterion - , deepseq diff --git a/lib/DBus/Client.hs b/lib/DBus/Client.hs --- a/lib/DBus/Client.hs +++ b/lib/DBus/Client.hs @@ -99,6 +99,7 @@ , matchPath , matchInterface , matchMember + , matchPathNamespace -- * Name reservation , requestName @@ -132,13 +133,14 @@ import Control.Monad (forever, forM_, when) import Data.Bits ((.|.)) import Data.IORef -import Data.List (foldl', intercalate) +import Data.List (foldl', intercalate, isPrefixOf) import qualified Data.Map import Data.Map (Map) import Data.Maybe (catMaybes, listToMaybe) import Data.Typeable (Typeable) import Data.Unique import Data.Word (Word32) +import Data.Function import DBus import qualified DBus.Introspection as I @@ -641,6 +643,10 @@ -- | If set, only receives signals sent with the given member name. , matchMember :: Maybe MemberName + + -- | If set, only receives signals sent with the given path or any of + -- its children. + , matchPathNamespace :: Maybe ObjectPath } instance Show MatchRule where @@ -655,6 +661,7 @@ , f "path" matchPath formatObjectPath , f "interface" matchInterface formatInterfaceName , f "member" matchMember formatMemberName + , f "path_namespace" matchPathNamespace formatObjectPath ] f :: String -> (MatchRule -> Maybe a) -> (a -> String) -> Maybe String @@ -664,7 +671,7 @@ -- | Match any signal. matchAny :: MatchRule -matchAny = MatchRule Nothing Nothing Nothing Nothing Nothing +matchAny = MatchRule Nothing Nothing Nothing Nothing Nothing Nothing checkMatchRule :: MatchRule -> Signal -> Bool checkMatchRule rule msg = and @@ -673,7 +680,9 @@ , maybe True (== signalPath msg) (matchPath rule) , maybe True (== signalInterface msg) (matchInterface rule) , maybe True (== signalMember msg) (matchMember rule) - ] + , maybe True (`pathPrefix` signalPath msg) (matchPathNamespace rule) + ] where + pathPrefix = isPrefixOf `on` formatObjectPath data MethodExc = MethodExc ErrorName [Variant] deriving (Show, Eq, Typeable) diff --git a/lib/DBus/Internal/Types.hs b/lib/DBus/Internal/Types.hs --- a/lib/DBus/Internal/Types.hs +++ b/lib/DBus/Internal/Types.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} -- Copyright (C) 2009-2012 John Millikin -- @@ -21,32 +23,33 @@ module DBus.Internal.Types where -import Control.Monad (liftM, when, (>=>)) -import Control.Exception (Exception, handle, throwIO) -import Data.ByteString (ByteString) +import Control.DeepSeq +import Control.Exception (Exception, handle, throwIO) +import Control.Monad (liftM, when, (>=>)) +import Data.ByteString (ByteString) +import Data.Char (ord) +import Data.Int +import Data.List (intercalate) +import Data.Map (Map) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import Data.Word +import GHC.Generics +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Types (Fd) +import Text.ParserCombinators.Parsec ((<|>), oneOf) import qualified Data.ByteString import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy import qualified Data.ByteString.Unsafe -import Data.Char (ord) -import Data.Int -import Data.List (intercalate) import qualified Data.Map -import Data.Map (Map) import qualified Data.String import qualified Data.Text -import Data.Text (Text) import qualified Data.Text.Lazy -import Data.Typeable (Typeable) import qualified Data.Vector -import Data.Vector (Vector) -import Data.Word import qualified Foreign -import System.IO.Unsafe (unsafePerformIO) -import System.Posix.Types (Fd) - import qualified Text.ParserCombinators.Parsec as Parsec -import Text.ParserCombinators.Parsec ((<|>), oneOf) data Type = TypeBoolean @@ -66,8 +69,10 @@ | TypeArray Type | TypeDictionary Type Type | TypeStructure [Type] - deriving (Eq, Ord) + deriving (Eq, Ord, Generic) +instance NFData Type + instance Show Type where showsPrec d = showString . showType (d > 10) @@ -103,7 +108,7 @@ -- -- for details. newtype Signature = Signature [Type] - deriving (Eq, Ord) + deriving (Eq, Ord, NFData) -- | Get the list of types in a signature. The inverse of 'signature'. signatureTypes :: Signature -> [Type] @@ -628,7 +633,7 @@ -- -- for details. newtype ObjectPath = ObjectPath String - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, NFData) formatObjectPath :: ObjectPath -> String formatObjectPath (ObjectPath s) = s @@ -671,7 +676,7 @@ -- -- for details. newtype InterfaceName = InterfaceName String - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, NFData) formatInterfaceName :: InterfaceName -> String formatInterfaceName (InterfaceName s) = s @@ -711,7 +716,7 @@ -- -- for details. newtype MemberName = MemberName String - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, NFData) formatMemberName :: MemberName -> String formatMemberName (MemberName s) = s @@ -748,7 +753,7 @@ -- -- for details. newtype ErrorName = ErrorName String - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, NFData) formatErrorName :: ErrorName -> String formatErrorName (ErrorName s) = s @@ -778,7 +783,7 @@ -- -- for details. newtype BusName = BusName String - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, NFData) formatBusName :: BusName -> String formatBusName (BusName s) = s diff --git a/tests/DBusTests.hs b/tests/DBusTests.hs --- a/tests/DBusTests.hs +++ b/tests/DBusTests.hs @@ -18,38 +18,38 @@ , main ) where -import Test.Chell +import Test.Tasty -import DBusTests.Address -import DBusTests.BusName -import DBusTests.Client -import DBusTests.ErrorName -import DBusTests.Integration -import DBusTests.InterfaceName -import DBusTests.Introspection -import DBusTests.MemberName -import DBusTests.Message -import DBusTests.ObjectPath -import DBusTests.Serialization -import DBusTests.Socket -import DBusTests.Signature -import DBusTests.Transport -import DBusTests.Variant -import DBusTests.Wire +import DBusTests.Address +import DBusTests.BusName +import DBusTests.Client +import DBusTests.ErrorName +import DBusTests.Integration +import DBusTests.InterfaceName +import DBusTests.Introspection +import DBusTests.MemberName +import DBusTests.Message +import DBusTests.ObjectPath +import DBusTests.Serialization +import DBusTests.Socket +import DBusTests.Signature +import DBusTests.Transport +import DBusTests.Variant +import DBusTests.Wire -- import all dbus modules here to ensure they show up in the coverage report, -- even if not tested. -import DBus () -import DBus.Client () -import DBus.Internal.Address () -import DBus.Internal.Message () -import DBus.Internal.Types () -import DBus.Internal.Wire () -import DBus.Introspection () -import DBus.Socket () +import DBus () +import DBus.Client () +import DBus.Internal.Address () +import DBus.Internal.Message () +import DBus.Internal.Types () +import DBus.Internal.Wire () +import DBus.Introspection () +import DBus.Socket () -tests :: [Suite] -tests = +tests :: TestTree +tests = testGroup "dbus" [ test_Address , test_BusName , test_Client @@ -69,4 +69,4 @@ ] main :: IO () -main = Test.Chell.defaultMain tests +main = defaultMain tests diff --git a/tests/DBusTests/Address.hs b/tests/DBusTests/Address.hs --- a/tests/DBusTests/Address.hs +++ b/tests/DBusTests/Address.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,22 +15,23 @@ module DBusTests.Address (test_Address) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding (property) - -import Data.Char (ord) -import Data.List (intercalate) -import Data.Map (Map) +import Data.Char (ord) +import Data.List (intercalate) +import Data.Map (Map) +import Data.Maybe +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Text.Printf (printf) import qualified Data.Map -import Text.Printf (printf) import DBus import DBusTests.Util (smallListOf, smallListOf1, withEnv) -test_Address :: Suite -test_Address = suite "Address" +test_Address :: TestTree +test_Address = testGroup "Address" [ test_BuildAddress , test_ParseAddress , test_ParseAddresses @@ -44,8 +43,8 @@ , test_GetStarterAddress ] -test_BuildAddress :: Test -test_BuildAddress = property "address" prop where +test_BuildAddress :: TestTree +test_BuildAddress = testProperty "address" prop where prop = forAll gen_Address check check (method, params) = case address method params of Nothing -> False @@ -54,8 +53,8 @@ , addressParameters addr == params ] -test_ParseAddress :: Test -test_ParseAddress = property "parseAddress" prop where +test_ParseAddress :: TestTree +test_ParseAddress = testProperty "parseAddress" prop where prop = forAll gen_AddressBytes check check (bytes, method, params) = case parseAddress bytes of Nothing -> False @@ -64,8 +63,8 @@ , addressParameters addr == params ] -test_ParseAddresses :: Test -test_ParseAddresses = property "parseAddresses" prop where +test_ParseAddresses :: TestTree +test_ParseAddresses = testProperty "parseAddresses" prop where prop = forAll gen_AddressesBytes checkMany checkMany (bytes, expectedAddrs) = case parseAddresses bytes of Nothing -> False @@ -78,32 +77,32 @@ , addressParameters addr == params ] -test_ParseInvalid :: Test -test_ParseInvalid = assertions "parse-invalid" $ do +test_ParseInvalid :: TestTree +test_ParseInvalid = testCase "parse-invalid" $ do -- empty - $expect (nothing (address "" Data.Map.empty)) - $expect (nothing (parseAddress "")) + Nothing @=? address "" Data.Map.empty + Nothing @=? parseAddress "" -- no colon - $expect (nothing (parseAddress "a")) + Nothing @=? parseAddress "a" -- no equals sign - $expect (nothing (parseAddress "a:b")) + Nothing @=? parseAddress "a:b" -- no parameter -- TODO: should this be OK? what about the trailing comma rule? - $expect (nothing (parseAddress "a:,")) + Nothing @=? parseAddress "a:," -- no key - $expect (nothing (address "" (Data.Map.fromList [("", "c")]))) - $expect (nothing (parseAddress "a:=c")) + Nothing @=? address "" (Data.Map.fromList [("", "c")]) + Nothing @=? parseAddress "a:=c" -- no value - $expect (nothing (address "" (Data.Map.fromList [("b", "")]))) - $expect (nothing (parseAddress "a:b=")) + Nothing @=? address "" (Data.Map.fromList [("b", "")]) + Nothing @=? parseAddress "a:b=" -test_FormatAddress :: Test -test_FormatAddress = property "formatAddress" prop where +test_FormatAddress :: TestTree +test_FormatAddress = testProperty "formatAddress" prop where prop = forAll gen_Address check where check (method, params) = let Just addr = address method params @@ -115,8 +114,8 @@ , shown == "Address " ++ show bytes ] -test_FormatAddresses :: Test -test_FormatAddresses = property "formatAddresses" prop where +test_FormatAddresses :: TestTree +test_FormatAddresses = testProperty "formatAddresses" prop where prop = forAll (smallListOf1 gen_Address) check where check pairs = let addrs = do @@ -127,28 +126,28 @@ parsed = parseAddresses bytes in parsed == Just addrs -test_GetSystemAddress :: Test -test_GetSystemAddress = assertions "getSystemAddress" $ do +test_GetSystemAddress :: TestTree +test_GetSystemAddress = testCase "getSystemAddress" $ do do addr <- withEnv "DBUS_SYSTEM_BUS_ADDRESS" Nothing getSystemAddress - $expect (just addr) - $assert (equal addr (address "unix" (Data.Map.fromList [("path", "/var/run/dbus/system_bus_socket")]))) + assertBool "can't get system address" $ isJust addr + addr @?= address "unix" (Data.Map.fromList [("path", "/var/run/dbus/system_bus_socket")]) do addr <- withEnv "DBUS_SYSTEM_BUS_ADDRESS" (Just "a:b=c") getSystemAddress - $expect (just addr) - $assert (equal addr (address "a" (Data.Map.fromList [("b", "c")]))) + assertBool "can't get system address" $ isJust addr + addr @?= address "a" (Data.Map.fromList [("b", "c")]) -test_GetSessionAddress :: Test -test_GetSessionAddress = assertions "getSessionAddress" $ do +test_GetSessionAddress :: TestTree +test_GetSessionAddress = testCase "getSessionAddress" $ do addr <- withEnv "DBUS_SESSION_BUS_ADDRESS" (Just "a:b=c") getSessionAddress - $expect (just addr) - $assert (equal addr (address "a" (Data.Map.fromList [("b", "c")]))) + assertBool "can't get session address" $ isJust addr + addr @?= address "a" (Data.Map.fromList [("b", "c")]) -test_GetStarterAddress :: Test -test_GetStarterAddress = assertions "getStarterAddress" $ do +test_GetStarterAddress :: TestTree +test_GetStarterAddress = testCase "getStarterAddress" $ do addr <- withEnv "DBUS_STARTER_ADDRESS" (Just "a:b=c") getStarterAddress - $expect (just addr) - $assert (equal addr (address "a" (Data.Map.fromList [("b", "c")]))) + assertBool "can't get starter address" $ isJust addr + addr @?= address "a" (Data.Map.fromList [("b", "c")]) gen_Address :: Gen (String, Map String String) gen_Address = gen where diff --git a/tests/DBusTests/BusName.hs b/tests/DBusTests/BusName.hs --- a/tests/DBusTests/BusName.hs +++ b/tests/DBusTests/BusName.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,54 +15,56 @@ module DBusTests.BusName (test_BusName) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding (property) - -import Data.List (intercalate) - -import DBus +import Data.List (intercalate) +import Data.Maybe (isJust) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import DBusTests.Util +import DBus +import DBusTests.Util -test_BusName :: Suite -test_BusName = suite "BusName" +test_BusName :: TestTree +test_BusName = testGroup "BusName" [ test_Parse , test_ParseInvalid , test_IsVariant ] -test_Parse :: Test -test_Parse = property "parse" prop where +test_Parse :: TestTree +test_Parse = testProperty "parse" prop where prop = forAll gen_BusName check check x = case parseBusName x of Nothing -> False Just parsed -> formatBusName parsed == x -test_ParseInvalid :: Test -test_ParseInvalid = assertions "parse-invalid" $ do +test_ParseInvalid :: TestTree +test_ParseInvalid = testCase "parse-invalid" $ do -- empty - $expect (nothing (parseBusName "")) + Nothing @=? parseBusName "" -- well-known starting with a digit - $expect (nothing (parseBusName "foo.0bar")) + Nothing @=? parseBusName "foo.0bar" -- well-known with one element - $expect (nothing (parseBusName "foo")) + Nothing @=? parseBusName "foo" -- unique with one element - $expect (nothing (parseBusName ":foo")) + Nothing @=? parseBusName ":foo" -- trailing characters - $expect (nothing (parseBusName "foo.bar!")) + Nothing @=? parseBusName "foo.bar!" -- at most 255 characters - $expect (just (parseBusName (":0." ++ replicate 251 'y'))) - $expect (just (parseBusName (":0." ++ replicate 252 'y'))) - $expect (nothing (parseBusName (":0." ++ replicate 253 'y'))) + assertBool "valid parse failed" + $ isJust (parseBusName (":0." ++ replicate 251 'y')) + assertBool "valid parse failed" + $ isJust (parseBusName (":0." ++ replicate 252 'y')) + Nothing @=? parseBusName (":0." ++ replicate 253 'y') -test_IsVariant :: Test -test_IsVariant = assertions "IsVariant" $ do +test_IsVariant :: TestTree +test_IsVariant = testCase "IsVariant" $ assertVariant TypeString (busName_ "foo.bar") gen_BusName :: Gen String diff --git a/tests/DBusTests/Client.hs b/tests/DBusTests/Client.hs --- a/tests/DBusTests/Client.hs +++ b/tests/DBusTests/Client.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,22 +15,21 @@ module DBusTests.Client (test_Client) where -import Control.Concurrent -import Control.Exception (try) -import Control.Monad.IO.Class (liftIO) +import Control.Concurrent +import Control.Exception (try) +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit import qualified Data.Map as Map -import Data.Word -import Test.Chell - -import DBus +import DBus import qualified DBus.Client import qualified DBus.Socket -import DBusTests.Util (forkVar, withEnv) +import DBusTests.Util -test_Client :: Suite -test_Client = suite "Client" $ +test_Client :: TestTree +test_Client = testGroup "Client" $ [ test_RequestName , test_ReleaseName , test_Call @@ -40,26 +37,27 @@ , test_AddMatch , test_AutoMethod , test_ExportIntrospection - ] ++ suiteTests suite_Connect + , suite_Connect + ] -test_Connect :: String -> (Address -> IO DBus.Client.Client) -> Test -test_Connect name connect = assertions name $ do +test_Connect :: String -> (Address -> IO DBus.Client.Client) -> TestTree +test_Connect name connect = testCase name $ do (addr, sockVar) <- startDummyBus clientVar <- forkVar (connect addr) -- TODO: verify that 'hello' contains expected data, and -- send a properly formatted reply. - sock <- liftIO (readMVar sockVar) - receivedHello <- liftIO (DBus.Socket.receive sock) + sock <- readMVar sockVar + receivedHello <- DBus.Socket.receive sock let (ReceivedMethodCall helloSerial _) = receivedHello - liftIO (DBus.Socket.send sock (methodReturn helloSerial) (\_ -> return ())) + DBus.Socket.send sock (methodReturn helloSerial) (\_ -> return ()) - client <- liftIO (readMVar clientVar) - liftIO (DBus.Client.disconnect client) + client <- readMVar clientVar + DBus.Client.disconnect client -suite_Connect :: Suite -suite_Connect = suite "connect" +suite_Connect :: TestTree +suite_Connect = testGroup "connect" [ test_ConnectSystem , test_ConnectSystem_NoAddress , test_ConnectSession @@ -68,51 +66,51 @@ , test_ConnectStarter_NoAddress ] -test_ConnectSystem :: Test -test_ConnectSystem = test_Connect "connectSystem" $ \addr -> do +test_ConnectSystem :: TestTree +test_ConnectSystem = test_Connect "connectSystem" $ \addr -> withEnv "DBUS_SYSTEM_BUS_ADDRESS" (Just (formatAddress addr)) DBus.Client.connectSystem -test_ConnectSystem_NoAddress :: Test -test_ConnectSystem_NoAddress = assertions "connectSystem-no-address" $ do - $expect $ throwsEq +test_ConnectSystem_NoAddress :: TestTree +test_ConnectSystem_NoAddress = testCase "connectSystem-no-address" $ + assertException (DBus.Client.clientError "connectSystem: DBUS_SYSTEM_BUS_ADDRESS is invalid.") (withEnv "DBUS_SYSTEM_BUS_ADDRESS" (Just "invalid") DBus.Client.connectSystem) -test_ConnectSession :: Test -test_ConnectSession = test_Connect "connectSession" $ \addr -> do +test_ConnectSession :: TestTree +test_ConnectSession = test_Connect "connectSession" $ \addr -> withEnv "DBUS_SESSION_BUS_ADDRESS" (Just (formatAddress addr)) DBus.Client.connectSession -test_ConnectSession_NoAddress :: Test -test_ConnectSession_NoAddress = assertions "connectSession-no-address" $ do - $expect $ throwsEq +test_ConnectSession_NoAddress :: TestTree +test_ConnectSession_NoAddress = testCase "connectSession-no-address" $ + assertException (DBus.Client.clientError "connectSession: DBUS_SESSION_BUS_ADDRESS is missing or invalid.") (withEnv "DBUS_SESSION_BUS_ADDRESS" (Just "invalid") DBus.Client.connectSession) -test_ConnectStarter :: Test -test_ConnectStarter = test_Connect "connectStarter" $ \addr -> do +test_ConnectStarter :: TestTree +test_ConnectStarter = test_Connect "connectStarter" $ \addr -> withEnv "DBUS_STARTER_ADDRESS" (Just (formatAddress addr)) DBus.Client.connectStarter -test_ConnectStarter_NoAddress :: Test -test_ConnectStarter_NoAddress = assertions "connectStarter-no-address" $ do - $expect $ throwsEq +test_ConnectStarter_NoAddress :: TestTree +test_ConnectStarter_NoAddress = testCase "connectStarter-no-address" $ + assertException (DBus.Client.clientError "connectStarter: DBUS_STARTER_ADDRESS is missing or invalid.") (withEnv "DBUS_STARTER_ADDRESS" (Just "invalid") DBus.Client.connectStarter) -test_RequestName :: Test -test_RequestName = assertions "requestName" $ do - (sock, client) <- startConnectedClient +test_RequestName :: TestTree +test_RequestName = withConnectedClient $ \res -> testCase "requestName" $ do + (sock, client) <- res let allFlags = [ DBus.Client.nameAllowReplacement , DBus.Client.nameReplaceExisting @@ -134,7 +132,7 @@ (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (1 :: Word32)]) - $expect (equal reply DBus.Client.NamePrimaryOwner) + reply @?= DBus.Client.NamePrimaryOwner -- NameInQueue do @@ -142,7 +140,7 @@ (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (2 :: Word32)]) - $expect (equal reply DBus.Client.NameInQueue) + reply @?= DBus.Client.NameInQueue -- NameExists do @@ -150,7 +148,7 @@ (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (3 :: Word32)]) - $expect (equal reply DBus.Client.NameExists) + reply @?= DBus.Client.NameExists -- NameAlreadyOwner do @@ -158,7 +156,7 @@ (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (4 :: Word32)]) - $expect (equal reply DBus.Client.NameAlreadyOwner) + reply @?= DBus.Client.NameAlreadyOwner -- response with empty body do @@ -166,10 +164,10 @@ (try (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)) requestCall (requestReply []) - err <- $requireLeft tried - $expect (equal err (DBus.Client.clientError "requestName: received empty response") + err <- requireLeft tried + err @?= (DBus.Client.clientError "requestName: received empty response") { DBus.Client.clientErrorFatal = False - }) + } -- response with invalid body do @@ -177,10 +175,10 @@ (try (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags)) requestCall (requestReply [toVariant ""]) - err <- $requireLeft tried - $expect (equal err (DBus.Client.clientError "requestName: received invalid response code (Variant \"\")") + err <- requireLeft tried + err @?= (DBus.Client.clientError "requestName: received invalid response code (Variant \"\")") { DBus.Client.clientErrorFatal = False - }) + } -- response with unknown result code do @@ -188,12 +186,11 @@ (DBus.Client.requestName client (busName_ "com.example.Foo") allFlags) requestCall (requestReply [toVariant (5 :: Word32)]) - $expect (equal (show reply) ("UnknownRequestNameReply 5")) - -test_ReleaseName :: Test -test_ReleaseName = assertions "releaseName" $ do - (sock, client) <- startConnectedClient + show reply @?= "UnknownRequestNameReply 5" +test_ReleaseName :: TestTree +test_ReleaseName = withConnectedClient $ \res -> testCase "releaseName" $ do + (sock, client) <- res let requestCall = (dbusCall "ReleaseName") { methodCallDestination = Just (busName_ "org.freedesktop.DBus") , methodCallBody = [toVariant "com.example.Foo"] @@ -209,7 +206,7 @@ (DBus.Client.releaseName client (busName_ "com.example.Foo")) requestCall (requestReply [toVariant (1 :: Word32)]) - $expect (equal reply DBus.Client.NameReleased) + reply @?= DBus.Client.NameReleased -- NameNonExistent do @@ -217,7 +214,7 @@ (DBus.Client.releaseName client (busName_ "com.example.Foo")) requestCall (requestReply [toVariant (2 :: Word32)]) - $expect (equal reply DBus.Client.NameNonExistent) + reply @?= DBus.Client.NameNonExistent -- NameNotOwner do @@ -225,7 +222,7 @@ (DBus.Client.releaseName client (busName_ "com.example.Foo")) requestCall (requestReply [toVariant (3 :: Word32)]) - $expect (equal reply DBus.Client.NameNotOwner) + reply @?= DBus.Client.NameNotOwner -- response with empty body do @@ -233,10 +230,10 @@ (try (DBus.Client.releaseName client (busName_ "com.example.Foo"))) requestCall (requestReply []) - err <- $requireLeft tried - $expect (equal err (DBus.Client.clientError "releaseName: received empty response") + err <- requireLeft tried + err @?= (DBus.Client.clientError "releaseName: received empty response") { DBus.Client.clientErrorFatal = False - }) + } -- response with invalid body do @@ -244,10 +241,10 @@ (try (DBus.Client.releaseName client (busName_ "com.example.Foo"))) requestCall (requestReply [toVariant ""]) - err <- $requireLeft tried - $expect (equal err (DBus.Client.clientError "releaseName: received invalid response code (Variant \"\")") + err <- requireLeft tried + err @?= (DBus.Client.clientError "releaseName: received invalid response code (Variant \"\")") { DBus.Client.clientErrorFatal = False - }) + } -- response with unknown result code do @@ -255,12 +252,11 @@ (DBus.Client.releaseName client (busName_ "com.example.Foo")) requestCall (requestReply [toVariant (5 :: Word32)]) - $expect (equal (show reply) ("UnknownReleaseNameReply 5")) - -test_Call :: Test -test_Call = assertions "call" $ do - (sock, client) <- startConnectedClient + show reply @?= "UnknownReleaseNameReply 5" +test_Call :: TestTree +test_Call = withConnectedClient $ \res -> testCase "call" $ do + (sock, client) <- res let requestCall = (dbusCall "Hello") { methodCallSender = Just (busName_ "com.example.Foo") , methodCallDestination = Just (busName_ "org.freedesktop.DBus") @@ -277,14 +273,13 @@ { methodCallReplyExpected = True }) methodReturn - reply <- $requireRight response - - $expect (equal reply (methodReturn (methodReturnSerial reply))) + reply <- requireRight response -test_CallNoReply :: Test -test_CallNoReply = assertions "callNoReply" $ do - (sock, client) <- startConnectedClient + reply @?= methodReturn (methodReturnSerial reply) +test_CallNoReply :: TestTree +test_CallNoReply = withConnectedClient $ \res -> testCase "callNoReply" $ do + (sock, client) <- res let requestCall = (dbusCall "Hello") { methodCallSender = Just (busName_ "com.example.Foo") , methodCallDestination = Just (busName_ "org.freedesktop.DBus") @@ -302,10 +297,9 @@ }) methodReturn -test_AddMatch :: Test -test_AddMatch = assertions "addMatch" $ do - (sock, client) <- startConnectedClient - +test_AddMatch :: TestTree +test_AddMatch = withConnectedClient $ \res -> testCase "addMatch" $ do + (sock, client) <- res let matchRule = DBus.Client.matchAny { DBus.Client.matchSender = Just (busName_ "com.example.Foo") , DBus.Client.matchDestination = Just (busName_ "com.example.Bar") @@ -315,92 +309,90 @@ } -- might as well test this while we're at it - $expect (equal (show matchRule) "MatchRule \"sender='com.example.Foo',destination='com.example.Bar',path='/',interface='com.example.Baz',member='Qux'\"") + show matchRule @?= "MatchRule \"sender='com.example.Foo',destination='com.example.Bar',path='/',interface='com.example.Baz',member='Qux'\"" let requestCall = (dbusCall "AddMatch") { methodCallDestination = Just (busName_ "org.freedesktop.DBus") , methodCallBody = [toVariant "type='signal',sender='com.example.Foo',destination='com.example.Bar',path='/',interface='com.example.Baz',member='Qux'"] } - signalVar <- liftIO newEmptyMVar + signalVar <- newEmptyMVar -- add a listener for the given signal - stubMethodCall sock + _ <- stubMethodCall sock (DBus.Client.addMatch client matchRule (putMVar signalVar)) requestCall methodReturn -- ignored signal - liftIO (DBus.Socket.send sock + DBus.Socket.send sock (signal (objectPath_ "/") (interfaceName_ "com.example.Baz") (memberName_ "Qux")) - (\_ -> return ())) - $assert (isEmptyMVar signalVar) + (\_ -> return ()) + isEmptyMVar signalVar >>= assertBool "signal not ignored" -- matched signal let matchedSignal = (signal (objectPath_ "/") (interfaceName_ "com.example.Baz") (memberName_ "Qux")) { signalSender = Just (busName_ "com.example.Foo") , signalDestination = Just (busName_ "com.example.Bar") } - liftIO (DBus.Socket.send sock matchedSignal (\_ -> return ())) - received <- liftIO (takeMVar signalVar) - $expect (equal received matchedSignal) - -test_AutoMethod :: Test -test_AutoMethod = assertions "autoMethod" $ do - (sock, client) <- startConnectedClient + DBus.Socket.send sock matchedSignal (\_ -> return ()) + received <- takeMVar signalVar + received @?= matchedSignal +test_AutoMethod :: TestTree +test_AutoMethod = withConnectedClient $ \res -> testCase "autoMethod" $ do + (sock, client) <- res let methodMax = (\x y -> return (max x y)) :: Word32 -> Word32 -> IO Word32 let methodPair = (\x y -> return (x, y)) :: String -> String -> IO (String, String) - liftIO (DBus.Client.export client (objectPath_ "/") + DBus.Client.export client (objectPath_ "/") [ DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Max") methodMax , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Pair") methodPair - ]) + ] -- valid call to com.example.Foo.Max do (serial, response) <- callClientMethod sock "/" "com.example.Foo" "Max" [toVariant (2 :: Word32), toVariant (1 :: Word32)] - $expect (equal response (Right (methodReturn serial) + response @?= Right (methodReturn serial) { methodReturnBody = [toVariant (2 :: Word32)] - })) + } -- valid call to com.example.Foo.Pair do (serial, response) <- callClientMethod sock "/" "com.example.Foo" "Pair" [toVariant "x", toVariant "y"] - $expect (equal response (Right (methodReturn serial) + response @?= Right (methodReturn serial) { methodReturnBody = [toVariant "x", toVariant "y"] - })) + } -- invalid call to com.example.Foo.Max do (serial, response) <- callClientMethod sock "/" "com.example.Foo" "Max" [toVariant "x", toVariant "y"] - $expect (equal response (Left (methodError serial (errorName_ "org.freedesktop.DBus.Error.InvalidParameters")))) - -test_ExportIntrospection :: Test -test_ExportIntrospection = assertions "exportIntrospection" $ do - (sock, client) <- startConnectedClient + response @?= Left (methodError serial (errorName_ "org.freedesktop.DBus.Error.InvalidParameters")) - liftIO (DBus.Client.export client (objectPath_ "/foo") +test_ExportIntrospection :: TestTree +test_ExportIntrospection = withConnectedClient $ \res -> testCase "exportIntrospection" $ do + (sock, client) <- res + DBus.Client.export client (objectPath_ "/foo") [ DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method1") (undefined :: String -> IO ()) , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method2") (undefined :: String -> IO String) , DBus.Client.autoMethod (interfaceName_ "com.example.Foo") (memberName_ "Method3") (undefined :: String -> IO (String, String)) - ]) + ] let introspect path = do (_, response) <- callClientMethod sock path "org.freedesktop.DBus.Introspectable" "Introspect" [] - ret <- $requireRight response + ret <- requireRight response let body = methodReturnBody ret - $assert (equal (length body) 1) + length body @?= 1 let Just xml = fromVariant (head body) return xml root <- introspect "/" - $expect (equalLines root + root @?= "\n\ \\ \\ @@ -409,10 +401,10 @@ \\ \\ \\ - \") + \" foo <- introspect "/foo" - $expect (equalLines foo + foo @?= "\n\ \\ \\ @@ -434,57 +426,58 @@ \\ \\ \\ - \") + \" -startDummyBus :: Assertions (Address, MVar DBus.Socket.Socket) +startDummyBus :: IO (Address, MVar DBus.Socket.Socket) startDummyBus = do - uuid <- liftIO randomUUID + uuid <- randomUUID let Just addr = address "unix" (Map.fromList [("abstract", formatUUID uuid)]) - listener <- liftIO (DBus.Socket.listen addr) + listener <- DBus.Socket.listen addr sockVar <- forkVar (DBus.Socket.accept listener) return (DBus.Socket.socketListenerAddress listener, sockVar) -startConnectedClient :: Assertions (DBus.Socket.Socket, DBus.Client.Client) -startConnectedClient = do - (addr, sockVar) <- startDummyBus - clientVar <- forkVar (DBus.Client.connect addr) - - -- TODO: verify that 'hello' contains expected data, and - -- send a properly formatted reply. - sock <- liftIO (readMVar sockVar) - receivedHello <- liftIO (DBus.Socket.receive sock) - let (ReceivedMethodCall helloSerial _) = receivedHello +withConnectedClient :: (IO (DBus.Socket.Socket, DBus.Client.Client) -> TestTree) -> TestTree +withConnectedClient = withResource create remove + where + create = do + (addr, sockVar) <- startDummyBus + clientVar <- forkVar (DBus.Client.connect addr) - liftIO (DBus.Socket.send sock (methodReturn helloSerial) (\_ -> return ())) + -- TODO: verify that 'hello' contains expected data, and + -- send a properly formatted reply. + sock <- readMVar sockVar + receivedHello <- DBus.Socket.receive sock + let (ReceivedMethodCall helloSerial _) = receivedHello - client <- liftIO (readMVar clientVar) - afterTest (DBus.Client.disconnect client) + DBus.Socket.send sock (methodReturn helloSerial) (\_ -> return ()) - return (sock, client) + client <- readMVar clientVar + return (sock, client) + remove (_, client) = DBus.Client.disconnect client -stubMethodCall :: DBus.Socket.Socket -> IO a -> MethodCall -> (Serial -> MethodReturn) -> Assertions a +stubMethodCall :: DBus.Socket.Socket -> IO a -> MethodCall -> (Serial -> MethodReturn) -> IO a stubMethodCall sock io expectedCall respond = do var <- forkVar io - receivedCall <- liftIO (DBus.Socket.receive sock) + receivedCall <- DBus.Socket.receive sock let ReceivedMethodCall callSerial call = receivedCall - $expect (equal expectedCall call) + expectedCall @?= call - liftIO (DBus.Socket.send sock (respond callSerial) (\_ -> return ())) + DBus.Socket.send sock (respond callSerial) (\_ -> return ()) - liftIO (takeMVar var) + takeMVar var -callClientMethod :: DBus.Socket.Socket -> String -> String -> String -> [Variant] -> Assertions (Serial, Either MethodError MethodReturn) +callClientMethod :: DBus.Socket.Socket -> String -> String -> String -> [Variant] -> IO (Serial, Either MethodError MethodReturn) callClientMethod sock path iface name body = do let call = (methodCall (objectPath_ path) (interfaceName_ iface) (memberName_ name)) { methodCallBody = body } - serial <- liftIO (DBus.Socket.send sock call return) - resp <- liftIO (DBus.Socket.receive sock) + serial <- DBus.Socket.send sock call return + resp <- DBus.Socket.receive sock case resp of ReceivedMethodReturn _ ret -> return (serial, Right ret) ReceivedMethodError _ err -> return (serial, Left err) - _ -> $die "callClientMethod: unexpected response to method call" + _ -> assertFailure "callClientMethod: unexpected response to method call" >> undefined dbusCall :: String -> MethodCall dbusCall member = methodCall (objectPath_ "/org/freedesktop/DBus") (interfaceName_ "org.freedesktop.DBus") (memberName_ member) diff --git a/tests/DBusTests/ErrorName.hs b/tests/DBusTests/ErrorName.hs --- a/tests/DBusTests/ErrorName.hs +++ b/tests/DBusTests/ErrorName.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,51 +15,54 @@ module DBusTests.ErrorName (test_ErrorName) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding (property) - -import Data.List (intercalate) +import Data.List (intercalate) +import Data.Maybe +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import DBus +import DBus -import DBusTests.Util +import DBusTests.Util -test_ErrorName :: Suite -test_ErrorName = suite "ErrorName" +test_ErrorName :: TestTree +test_ErrorName = testGroup "ErrorName" [ test_Parse , test_ParseInvalid , test_IsVariant ] -test_Parse :: Test -test_Parse = property "parse" prop where +test_Parse :: TestTree +test_Parse = testProperty "parse" prop where prop = forAll gen_ErrorName check check x = case parseErrorName x of Nothing -> False Just parsed -> formatErrorName parsed == x -test_ParseInvalid :: Test -test_ParseInvalid = assertions "parse-invalid" $ do +test_ParseInvalid :: TestTree +test_ParseInvalid = testCase "parse-invalid" $ do -- empty - $expect (nothing (parseErrorName "")) + Nothing @=? parseErrorName "" -- one element - $expect (nothing (parseErrorName "foo")) + Nothing @=? parseErrorName "foo" -- element starting with a digit - $expect (nothing (parseErrorName "foo.0bar")) + Nothing @=? parseErrorName "foo.0bar" -- trailing characters - $expect (nothing (parseErrorName "foo.bar!")) + Nothing @=? parseErrorName "foo.bar!" -- at most 255 characters - $expect (just (parseErrorName ("f." ++ replicate 252 'y'))) - $expect (just (parseErrorName ("f." ++ replicate 253 'y'))) - $expect (nothing (parseErrorName ("f." ++ replicate 254 'y'))) + assertBool "valid parse failed" + $ isJust (parseErrorName ("f." ++ replicate 252 'y')) + assertBool "valid parse failed" + $ isJust (parseErrorName ("f." ++ replicate 253 'y')) + Nothing @=? parseErrorName ("f." ++ replicate 254 'y') -test_IsVariant :: Test -test_IsVariant = assertions "IsVariant" $ do +test_IsVariant :: TestTree +test_IsVariant = testCase "IsVariant" $ assertVariant TypeString (errorName_ "foo.bar") gen_ErrorName :: Gen String diff --git a/tests/DBusTests/Integration.hs b/tests/DBusTests/Integration.hs --- a/tests/DBusTests/Integration.hs +++ b/tests/DBusTests/Integration.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2012 John Millikin -- @@ -18,79 +17,78 @@ module DBusTests.Integration (test_Integration) where -import Test.Chell - -import Control.Exception (finally) -import Control.Monad.IO.Class (liftIO) -import System.Directory (removeFile) -import System.Exit -import System.IO (hGetLine, writeFile) -import System.Process +import Control.Exception (finally) +import System.Directory (removeFile) +import System.Exit +import System.IO (hGetLine) +import System.Process +import Test.Tasty +import Test.Tasty.HUnit -import DBus -import DBus.Socket -import DBus.Client -import DBusTests.Util (getTempPath) +import DBus +import DBus.Socket +import DBus.Client +import DBusTests.Util -test_Integration :: Suite -test_Integration = suite "integration" +test_Integration :: TestTree +test_Integration = testGroup "Integration" [ test_Socket , test_Client ] -test_Socket :: Test +test_Socket :: TestTree test_Socket = withDaemon "socket" $ \addr -> do let hello = (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "Hello") { methodCallDestination = Just "org.freedesktop.DBus" } - sock <- liftIO (open addr) - serial <- liftIO (send sock hello return) - $expect (greaterEqual (serialValue serial) 1) + sock <- open addr + serial <- send sock hello return + assertBool "invalid serial" $ serialValue serial >= 1 - received <- liftIO (receive sock) + received <- receive sock let ReceivedMethodReturn _ ret = received - $expect (equal (methodReturnSerial ret) serial) - $expect (equal (methodReturnSender ret) (Just "org.freedesktop.DBus")) + methodReturnSerial ret @?= serial + methodReturnSender ret @?= Just "org.freedesktop.DBus" - liftIO (close sock) + close sock -test_Client :: Test +test_Client :: TestTree test_Client = withDaemon "client" $ \addr -> do - clientA <- liftIO (connect addr) - clientB <- liftIO (connect addr) + clientA <- connect addr + clientB <- connect addr - liftIO (export clientA "/" + export clientA "/" [ method "com.example.Echo" "Echo" (signature_ [TypeString]) (signature_ []) ( \msg -> if map variantType (methodCallBody msg) == [TypeString] then return (replyReturn (methodCallBody msg)) else return (replyError "com.example.Error" [toVariant ("bad body: " ++ show (methodCallBody msg))])) - ]) + ] -- TODO: get bus address of clientA with a function let busAddrA = ":1.0" -- Successful call let bodyGood = [toVariant ("test" :: String)] - retGood <- liftIO (call clientB (methodCall "/" "com.example.Echo" "Echo") + retGood <- call clientB (methodCall "/" "com.example.Echo" "Echo") { methodCallDestination = Just busAddrA , methodCallBody = bodyGood - }) - ret <- $requireRight retGood - $expect (equal (methodReturnBody ret) bodyGood) + } + ret <- requireRight retGood + methodReturnBody ret @?= bodyGood -- Failed call let bodyBad = [toVariant True] - retBad <- liftIO (call clientB (methodCall "/" "com.example.Echo" "Echo") + retBad <- call clientB (methodCall "/" "com.example.Echo" "Echo") { methodCallDestination = Just busAddrA , methodCallBody = bodyBad - }) - err <- $requireLeft retBad - $expect (equal (methodErrorName err) "com.example.Error") - $expect (equal (methodErrorBody err) [toVariant ("bad body: [Variant True]" :: String)]) + } + err <- requireLeft retBad + methodErrorName err @?= "com.example.Error" + methodErrorBody err @?= [toVariant ("bad body: [Variant True]" :: String)] - liftIO (disconnect clientA) - liftIO (disconnect clientB) + disconnect clientA + disconnect clientB configFileContent :: String configFileContent = "\ @@ -110,13 +108,13 @@ \ \ \" -withDaemon :: String -> (Address -> Assertions ()) -> Test -withDaemon name io = test name $ \opts -> do +withDaemon :: String -> (Address -> Assertion) -> TestTree +withDaemon name io = testCase name $ do (versionExit, _, _) <- readProcessWithExitCode "dbus-daemon" ["--version"] "" case versionExit of - ExitFailure _ -> return TestSkipped + ExitFailure _ -> assertFailure $ "dbus-daemon failed: " ++ show versionExit ExitSuccess -> do - configFilePath <- liftIO getTempPath + configFilePath <- getTempPath writeFile configFilePath configFileContent daemon <- createProcess (proc "dbus-daemon" ["--config-file=" ++ configFilePath, "--print-address"]) { std_out = CreatePipe @@ -127,8 +125,8 @@ (do addrString <- hGetLine daemonStdout case parseAddress addrString of - Nothing -> return (TestAborted [] ("dbus-daemon returned invalid address: " ++ show addrString)) - Just addr -> runTest (assertions name (io addr)) opts) + Nothing -> assertFailure $ "dbus-daemon returned invalid address: " ++ show addrString + Just addr -> io addr) (do terminateProcess daemonProc _ <- waitForProcess daemonProc diff --git a/tests/DBusTests/InterfaceName.hs b/tests/DBusTests/InterfaceName.hs --- a/tests/DBusTests/InterfaceName.hs +++ b/tests/DBusTests/InterfaceName.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,51 +15,54 @@ module DBusTests.InterfaceName (test_InterfaceName) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding (property) - -import Data.List (intercalate) +import Data.List (intercalate) +import Data.Maybe +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import DBus +import DBus -import DBusTests.Util +import DBusTests.Util -test_InterfaceName :: Suite -test_InterfaceName = suite "InterfaceName" +test_InterfaceName :: TestTree +test_InterfaceName = testGroup "InterfaceName" [ test_Parse , test_ParseInvalid , test_IsVariant ] -test_Parse :: Test -test_Parse = property "parse" prop where +test_Parse :: TestTree +test_Parse = testProperty "parse" prop where prop = forAll gen_InterfaceName check check x = case parseInterfaceName x of Nothing -> False Just parsed -> formatInterfaceName parsed == x -test_ParseInvalid :: Test -test_ParseInvalid = assertions "parse-invalid" $ do +test_ParseInvalid :: TestTree +test_ParseInvalid = testCase "parse-invalid" $ do -- empty - $expect (nothing (parseInterfaceName "")) + Nothing @=? parseInterfaceName "" -- one element - $expect (nothing (parseInterfaceName "foo")) + Nothing @=? parseInterfaceName "foo" -- element starting with a digit - $expect (nothing (parseInterfaceName "foo.0bar")) + Nothing @=? parseInterfaceName "foo.0bar" -- trailing characters - $expect (nothing (parseInterfaceName "foo.bar!")) + Nothing @=? parseInterfaceName "foo.bar!" -- at most 255 characters - $expect (just (parseInterfaceName ("f." ++ replicate 252 'y'))) - $expect (just (parseInterfaceName ("f." ++ replicate 253 'y'))) - $expect (nothing (parseInterfaceName ("f." ++ replicate 254 'y'))) + assertBool "valid parse failed" + $ isJust (parseInterfaceName ("f." ++ replicate 252 'y')) + assertBool "valid parse failed" + $ isJust (parseInterfaceName ("f." ++ replicate 253 'y')) + Nothing @=? parseInterfaceName ("f." ++ replicate 254 'y') -test_IsVariant :: Test -test_IsVariant = assertions "IsVariant" $ do +test_IsVariant :: TestTree +test_IsVariant = testCase "IsVariant" $ assertVariant TypeString (interfaceName_ "foo.bar") gen_InterfaceName :: Gen String diff --git a/tests/DBusTests/Introspection.hs b/tests/DBusTests/Introspection.hs --- a/tests/DBusTests/Introspection.hs +++ b/tests/DBusTests/Introspection.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,83 +15,81 @@ module DBusTests.Introspection (test_Introspection) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding (property) - -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (liftM, liftM2) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (liftM, liftM2) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import DBus +import DBus import qualified DBus.Introspection as Introspection -import DBusTests.InterfaceName () -import DBusTests.MemberName () -import DBusTests.ObjectPath () -import DBusTests.Signature () -import DBusTests.Util (halfSized) +import DBusTests.InterfaceName () +import DBusTests.MemberName () +import DBusTests.ObjectPath () +import DBusTests.Signature () +import DBusTests.Util (halfSized) -test_Introspection :: Suite -test_Introspection = suite "Introspection" +test_Introspection :: TestTree +test_Introspection = testGroup "Introspection" [ test_XmlPassthrough , test_XmlParse , test_XmlParseFailed , test_XmlWriteFailed ] -test_XmlPassthrough :: Test -test_XmlPassthrough = property "xml-passthrough" $ \obj -> let +test_XmlPassthrough :: TestTree +test_XmlPassthrough = testProperty "xml-passthrough" $ \obj -> let path = Introspection.objectPath obj Just xml = Introspection.formatXML obj in Introspection.parseXML path xml == Just obj -test_XmlParse :: Test -test_XmlParse = assertions "xml-parse" $ do +test_XmlParse :: TestTree +test_XmlParse = testCase "xml-parse" $ do -- root object path can be inferred - $expect (equal - (Introspection.parseXML (objectPath_ "/") "") - (Just (Introspection.object (objectPath_ "/")) + Introspection.parseXML (objectPath_ "/") "" + @?= Just (Introspection.object (objectPath_ "/")) { Introspection.objectChildren = [ Introspection.object (objectPath_ "/foo") ] } - )) -test_XmlParseFailed :: Test -test_XmlParseFailed = assertions "xml-parse-failed" $ do - $expect (nothing (Introspection.parseXML (objectPath_ "/") "")) - $expect (nothing (Introspection.parseXML (objectPath_ "/") "")) +test_XmlParseFailed :: TestTree +test_XmlParseFailed = testCase "xml-parse-failed" $ do + Nothing @=? Introspection.parseXML (objectPath_ "/") "" + Nothing @=? Introspection.parseXML (objectPath_ "/") "" -- invalid property access - $expect (nothing (Introspection.parseXML (objectPath_ "/") + Nothing @=? Introspection.parseXML (objectPath_ "/") "\ \ \ \ \ \ \ \ \ - \")) + \" -- invalid parameter type - $expect (nothing (Introspection.parseXML (objectPath_ "/") + Nothing @=? Introspection.parseXML (objectPath_ "/") "\ \ \ \ \ \ \ \ \ \ \ - \")) + \" -test_XmlWriteFailed :: Test -test_XmlWriteFailed = assertions "xml-write-failed" $ do +test_XmlWriteFailed :: TestTree +test_XmlWriteFailed = testCase "xml-write-failed" $ do -- child's object path isn't under parent's - $expect (nothing (Introspection.formatXML (Introspection.object (objectPath_ "/foo")) + Nothing @=? Introspection.formatXML (Introspection.object (objectPath_ "/foo")) { Introspection.objectChildren = [ Introspection.object (objectPath_ "/bar") ] - })) + } -- invalid type - $expect (nothing (Introspection.formatXML (Introspection.object (objectPath_ "/foo")) + Nothing @=? Introspection.formatXML (Introspection.object (objectPath_ "/foo")) { Introspection.objectInterfaces = [ (Introspection.interface (interfaceName_ "/bar")) { Introspection.interfaceProperties = @@ -101,7 +97,7 @@ ] } ] - })) + } instance Arbitrary Type where arbitrary = oneof [atom, container] where diff --git a/tests/DBusTests/MemberName.hs b/tests/DBusTests/MemberName.hs --- a/tests/DBusTests/MemberName.hs +++ b/tests/DBusTests/MemberName.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,46 +15,50 @@ module DBusTests.MemberName (test_MemberName) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding (property) +import Data.Maybe +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import DBus +import DBus -import DBusTests.Util +import DBusTests.Util -test_MemberName :: Suite -test_MemberName = suite "MemberName" +test_MemberName :: TestTree +test_MemberName = testGroup "MemberName" [ test_Parse , test_ParseInvalid , test_IsVariant ] -test_Parse :: Test -test_Parse = property "parse" prop where +test_Parse :: TestTree +test_Parse = testProperty "parse" prop where prop = forAll gen_MemberName check check x = case parseMemberName x of Nothing -> False Just parsed -> formatMemberName parsed == x -test_ParseInvalid :: Test -test_ParseInvalid = assertions "parse-invalid" $ do +test_ParseInvalid :: TestTree +test_ParseInvalid = testCase "parse-invalid" $ do -- empty - $expect (nothing (parseMemberName "")) + Nothing @=? parseMemberName "" -- starts with a digit - $expect (nothing (parseMemberName "@foo")) + Nothing @=? parseMemberName "@foo" -- trailing chars - $expect (nothing (parseMemberName "foo!")) + Nothing @=? parseMemberName "foo!" -- at most 255 characters - $expect (just (parseMemberName (replicate 254 'y'))) - $expect (just (parseMemberName (replicate 255 'y'))) - $expect (nothing (parseMemberName (replicate 256 'y'))) + assertBool "valid parse failed" + $ isJust (parseMemberName (replicate 254 'y')) + assertBool "valid parse failed" + $ isJust (parseMemberName (replicate 255 'y')) + Nothing @=? parseMemberName (replicate 256 'y') -test_IsVariant :: Test -test_IsVariant = assertions "IsVariant" $ do +test_IsVariant :: TestTree +test_IsVariant = testCase "IsVariant" $ assertVariant TypeString (memberName_ "foo") gen_MemberName :: Gen String diff --git a/tests/DBusTests/Message.hs b/tests/DBusTests/Message.hs --- a/tests/DBusTests/Message.hs +++ b/tests/DBusTests/Message.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,36 +15,33 @@ module DBusTests.Message (test_Message) where -import Test.Chell +import Test.Tasty +import Test.Tasty.HUnit import DBus -test_Message :: Suite -test_Message = suite "Message" +test_Message :: TestTree +test_Message = testGroup "Message" [ test_MethodErrorMessage ] -test_MethodErrorMessage :: Test -test_MethodErrorMessage = assertions "methodErrorMessage" $ do +test_MethodErrorMessage :: TestTree +test_MethodErrorMessage = testCase "methodErrorMessage" $ do let emptyError = methodError firstSerial (errorName_ "com.example.Error") - $expect (equal - "(no error message)" - (methodErrorMessage emptyError + "(no error message)" @=? + methodErrorMessage emptyError { methodErrorBody = [] - })) - $expect (equal - "(no error message)" - (methodErrorMessage emptyError + } + "(no error message)" @=? + methodErrorMessage emptyError { methodErrorBody = [toVariant True] - })) - $expect (equal - "(no error message)" - (methodErrorMessage emptyError + } + "(no error message)" @=? + methodErrorMessage emptyError { methodErrorBody = [toVariant ""] - })) - $expect (equal - "error" - (methodErrorMessage emptyError + } + "error" @=? + methodErrorMessage emptyError { methodErrorBody = [toVariant "error"] - })) + } diff --git a/tests/DBusTests/ObjectPath.hs b/tests/DBusTests/ObjectPath.hs --- a/tests/DBusTests/ObjectPath.hs +++ b/tests/DBusTests/ObjectPath.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,43 +15,43 @@ module DBusTests.ObjectPath (test_ObjectPath) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding (property) - -import Data.List (intercalate) +import Data.List (intercalate) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import DBus +import DBus -test_ObjectPath :: Suite -test_ObjectPath = suite "ObjectPath" +test_ObjectPath :: TestTree +test_ObjectPath = testGroup "ObjectPath" [ test_Parse , test_ParseInvalid ] -test_Parse :: Test -test_Parse = property "parse" prop where +test_Parse :: TestTree +test_Parse = testProperty "parse" prop where prop = forAll gen_ObjectPath check check x = case parseObjectPath x of Nothing -> False Just parsed -> formatObjectPath parsed == x -test_ParseInvalid :: Test -test_ParseInvalid = assertions "parse-invalid" $ do +test_ParseInvalid :: TestTree +test_ParseInvalid = testCase "parse-invalid" $ do -- empty - $expect (nothing (parseObjectPath "")) + Nothing @=? parseObjectPath "" -- bad char - $expect (nothing (parseObjectPath "/f!oo")) + Nothing @=? parseObjectPath "/f!oo" -- ends with a slash - $expect (nothing (parseObjectPath "/foo/")) + Nothing @=? parseObjectPath "/foo/" -- empty element - $expect (nothing (parseObjectPath "/foo//bar")) + Nothing @=? parseObjectPath "/foo//bar" -- trailing chars - $expect (nothing (parseObjectPath "/foo!")) + Nothing @=? parseObjectPath "/foo!" gen_ObjectPath :: Gen String gen_ObjectPath = gen where diff --git a/tests/DBusTests/Serialization.hs b/tests/DBusTests/Serialization.hs --- a/tests/DBusTests/Serialization.hs +++ b/tests/DBusTests/Serialization.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2010-2012 John Millikin -- @@ -18,65 +17,65 @@ module DBusTests.Serialization (test_Serialization) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding ((.&.), property) - -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Int (Int16, Int32, Int64) -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Map (Map) +import Data.ByteString (ByteString) +import Data.Int (Int16, Int32, Int64) +import Data.Map (Map) +import Data.Text (Text) +import Data.Word (Word8, Word16, Word32, Word64) +import Foreign.C.Types (CInt) +import System.Posix.Types (Fd) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck import qualified Data.Map import qualified Data.Vector -import Foreign.C.Types (CInt) -import System.Posix.Types (Fd) -import DBus +import DBus import qualified DBus.Internal.Types -import DBusTests.BusName () -import DBusTests.ErrorName () -import DBusTests.InterfaceName () -import DBusTests.MemberName () -import DBusTests.ObjectPath () -import DBusTests.Signature () -import DBusTests.Util (smallListOf) +import DBusTests.BusName () +import DBusTests.ErrorName () +import DBusTests.InterfaceName () +import DBusTests.MemberName () +import DBusTests.ObjectPath () +import DBusTests.Signature () +import DBusTests.Util (smallListOf) -test_Serialization :: Suite -test_Serialization = suite "Serialization" +test_Serialization :: TestTree +test_Serialization = testGroup "Serialization" [ test_MethodCall , test_MethodReturn , test_MethodError , test_Signal ] -test_MethodCall :: Test -test_MethodCall = property "MethodCall" prop where +test_MethodCall :: TestTree +test_MethodCall = testProperty "MethodCall" prop where prop = forAll gen_MethodCall check check msg endianness serial = let Right bytes = marshal endianness serial msg Right received = unmarshal bytes in ReceivedMethodCall serial msg == received -test_MethodReturn :: Test -test_MethodReturn = property "MethodReturn" prop where +test_MethodReturn :: TestTree +test_MethodReturn = testProperty "MethodReturn" prop where prop = forAll gen_MethodReturn check check msg endianness serial = let Right bytes = marshal endianness serial msg Right received = unmarshal bytes in ReceivedMethodReturn serial msg == received -test_MethodError :: Test -test_MethodError = property "MethodError" prop where +test_MethodError :: TestTree +test_MethodError = testProperty "MethodError" prop where prop = forAll gen_MethodError check check msg endianness serial = let Right bytes = marshal endianness serial msg Right received = unmarshal bytes in ReceivedMethodError serial msg == received -test_Signal :: Test -test_Signal = property "Signal" prop where +test_Signal :: TestTree +test_Signal = testProperty "Signal" prop where prop = forAll gen_Signal check check msg endianness serial = let Right bytes = marshal endianness serial msg diff --git a/tests/DBusTests/Signature.hs b/tests/DBusTests/Signature.hs --- a/tests/DBusTests/Signature.hs +++ b/tests/DBusTests/Signature.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -17,16 +15,18 @@ module DBusTests.Signature (test_Signature) where -import Test.Chell -import Test.Chell.QuickCheck -import Test.QuickCheck hiding ((.&.), property) +import Data.Maybe +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import DBus +import DBus -import DBusTests.Util +import DBusTests.Util -test_Signature :: Suite -test_Signature = suite "Signature" +test_Signature :: TestTree +test_Signature = testGroup "Signature" [ test_BuildSignature , test_ParseSignature , test_ParseInvalid @@ -35,77 +35,80 @@ , test_ShowType ] -test_BuildSignature :: Test -test_BuildSignature = property "signature" prop where +test_BuildSignature :: TestTree +test_BuildSignature = testProperty "signature" prop where prop = forAll gen_SignatureTypes check check types = case signature types of Nothing -> False Just sig -> signatureTypes sig == types -test_ParseSignature :: Test -test_ParseSignature = property "parseSignature" prop where +test_ParseSignature :: TestTree +test_ParseSignature = testProperty "parseSignature" prop where prop = forAll gen_SignatureString check check (s, types) = case parseSignature s of Nothing -> False Just sig -> signatureTypes sig == types -test_ParseInvalid :: Test -test_ParseInvalid = assertions "parse-invalid" $ do +test_ParseInvalid :: TestTree +test_ParseInvalid = testCase "parse-invalid" $ do -- at most 255 characters - $expect (just (parseSignature (replicate 254 'y'))) - $expect (just (parseSignature (replicate 255 'y'))) - $expect (nothing (parseSignature (replicate 256 'y'))) + assertBool "valid parse failed" $ + isJust (parseSignature (replicate 254 'y')) + assertBool "valid parse failed" $ + isJust (parseSignature (replicate 255 'y')) + Nothing @=? parseSignature (replicate 256 'y') -- length also enforced by 'signature' - $expect (just (signature (replicate 255 TypeWord8))) - $expect (nothing (signature (replicate 256 TypeWord8))) + assertBool "valid parse failed" $ + isJust (signature (replicate 255 TypeWord8)) + Nothing @=? signature (replicate 256 TypeWord8) -- struct code - $expect (nothing (parseSignature "r")) + Nothing @=? parseSignature "r" -- empty struct - $expect (nothing (parseSignature "()")) - $expect (nothing (signature [TypeStructure []])) + Nothing @=? parseSignature "()" + Nothing @=? signature [TypeStructure []] -- dict code - $expect (nothing (parseSignature "e")) + Nothing @=? parseSignature "e" -- non-atomic dict key - $expect (nothing (parseSignature "a{vy}")) - $expect (nothing (signature [TypeDictionary TypeVariant TypeVariant])) + Nothing @=? parseSignature "a{vy}" + Nothing @=? signature [TypeDictionary TypeVariant TypeVariant] -test_FormatSignature :: Test -test_FormatSignature = property "formatSignature" prop where +test_FormatSignature :: TestTree +test_FormatSignature = testProperty "formatSignature" prop where prop = forAll gen_SignatureString check check (s, _) = let Just sig = parseSignature s in formatSignature sig == s -test_IsAtom :: Test -test_IsAtom = assertions "IsAtom" $ do +test_IsAtom :: TestTree +test_IsAtom = testCase "IsAtom" $ do let Just sig = signature [] assertAtom TypeSignature sig -test_ShowType :: Test -test_ShowType = assertions "show-type" $ do - $expect (equal "Bool" (show TypeBoolean)) - $expect (equal "Bool" (show TypeBoolean)) - $expect (equal "Word8" (show TypeWord8)) - $expect (equal "Word16" (show TypeWord16)) - $expect (equal "Word32" (show TypeWord32)) - $expect (equal "Word64" (show TypeWord64)) - $expect (equal "Int16" (show TypeInt16)) - $expect (equal "Int32" (show TypeInt32)) - $expect (equal "Int64" (show TypeInt64)) - $expect (equal "Double" (show TypeDouble)) - $expect (equal "UnixFd" (show TypeUnixFd)) - $expect (equal "String" (show TypeString)) - $expect (equal "Signature" (show TypeSignature)) - $expect (equal "ObjectPath" (show TypeObjectPath)) - $expect (equal "Variant" (show TypeVariant)) - $expect (equal "[Word8]" (show (TypeArray TypeWord8))) - $expect (equal "Dict Word8 (Dict Word8 Word8)" (show (TypeDictionary TypeWord8 (TypeDictionary TypeWord8 TypeWord8)))) - $expect (equal "(Word8, Word16)" (show (TypeStructure [TypeWord8, TypeWord16]))) +test_ShowType :: TestTree +test_ShowType = testCase "show-type" $ do + "Bool" @=? show TypeBoolean + "Bool" @=? show TypeBoolean + "Word8" @=? show TypeWord8 + "Word16" @=? show TypeWord16 + "Word32" @=? show TypeWord32 + "Word64" @=? show TypeWord64 + "Int16" @=? show TypeInt16 + "Int32" @=? show TypeInt32 + "Int64" @=? show TypeInt64 + "Double" @=? show TypeDouble + "UnixFd" @=? show TypeUnixFd + "String" @=? show TypeString + "Signature" @=? show TypeSignature + "ObjectPath" @=? show TypeObjectPath + "Variant" @=? show TypeVariant + "[Word8]" @=? show (TypeArray TypeWord8) + "Dict Word8 (Dict Word8 Word8)" @=? show (TypeDictionary TypeWord8 (TypeDictionary TypeWord8 TypeWord8)) + "(Word8, Word16)" @=? show (TypeStructure [TypeWord8, TypeWord16]) gen_SignatureTypes :: Gen [Type] gen_SignatureTypes = do diff --git a/tests/DBusTests/Socket.hs b/tests/DBusTests/Socket.hs --- a/tests/DBusTests/Socket.hs +++ b/tests/DBusTests/Socket.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2012 John Millikin -- @@ -18,70 +17,64 @@ module DBusTests.Socket (test_Socket) where -import Test.Chell - -import Control.Concurrent -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent +import Control.Exception +import Test.Tasty +import Test.Tasty.HUnit import qualified Data.Map as Map -import DBus -import DBus.Socket -import DBus.Transport +import DBus +import DBus.Socket +import DBus.Transport -import DBusTests.Util (forkVar) +import DBusTests.Util (forkVar) -test_Socket :: Suite -test_Socket = suite "Socket" +test_Socket :: TestTree +test_Socket = testGroup "Socket" [ test_Listen , test_ListenWith_CustomAuth , test_SendReceive ] -test_Listen :: Test -test_Listen = assertions "listen" $ do - uuid <- liftIO randomUUID +test_Listen :: TestTree +test_Listen = testCase "listen" $ do + uuid <- randomUUID let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ]) - listener <- liftIO (listen addr) - afterTest (closeListener listener) - - acceptedVar <- forkVar (accept listener) - openedVar <- forkVar (open addr) - - sock1 <- liftIO (takeMVar acceptedVar) - afterTest (close sock1) + bracket (listen addr) closeListener $ \listener -> do + acceptedVar <- forkVar (accept listener) + openedVar <- forkVar (open addr) - sock2 <- liftIO (takeMVar openedVar) - afterTest (close sock2) + sock1 <- takeMVar acceptedVar + sock2 <- takeMVar openedVar + close sock1 + close sock2 -test_ListenWith_CustomAuth :: Test -test_ListenWith_CustomAuth = assertions "listenWith-custom-auth" $ do - uuid <- liftIO randomUUID +test_ListenWith_CustomAuth :: TestTree +test_ListenWith_CustomAuth = testCase "listenWith-custom-auth" $ do + uuid <- randomUUID let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ]) - listener <- liftIO (listenWith (defaultSocketOptions - { socketAuthenticator = dummyAuth - }) addr) - afterTest (closeListener listener) - - acceptedVar <- forkVar (accept listener) - openedVar <- forkVar (openWith (defaultSocketOptions - { socketAuthenticator = dummyAuth - }) addr) - - sock1 <- liftIO (takeMVar acceptedVar) - afterTest (close sock1) + bracket (listenWith (defaultSocketOptions + { socketAuthenticator = dummyAuth + }) addr) closeListener $ \listener -> do + acceptedVar <- forkVar (accept listener) + openedVar <- forkVar (openWith (defaultSocketOptions + { socketAuthenticator = dummyAuth + }) addr) - sock2 <- liftIO (takeMVar openedVar) - afterTest (close sock2) + sock1 <- takeMVar acceptedVar + sock2 <- takeMVar openedVar + close sock1 + close sock2 -test_SendReceive :: Test -test_SendReceive = assertions "send-receive" $ do - uuid <- liftIO randomUUID +test_SendReceive :: TestTree +test_SendReceive = testCase "send-receive" $ do + uuid <- randomUUID let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ]) @@ -94,43 +87,37 @@ , methodCallBody = [toVariant True] } - listener <- liftIO (listen addr) - afterTest (closeListener listener) - - acceptedVar <- forkVar (accept listener) - openedVar <- forkVar (open addr) - - sock1 <- liftIO (takeMVar acceptedVar) - afterTest (close sock1) - - sock2 <- liftIO (takeMVar openedVar) - afterTest (close sock2) + bracket (listen addr) closeListener $ \listener -> do + acceptedVar <- forkVar (accept listener) + openedVar <- forkVar (open addr) - -- client -> server - do - serialVar <- liftIO newEmptyMVar - sentVar <- forkVar (send sock2 msg (putMVar serialVar)) - receivedVar <- forkVar (receive sock1) + bracket (takeMVar acceptedVar) close $ \sock1 -> do + bracket (takeMVar openedVar) close $ \sock2 -> do + -- client -> server + do + serialVar <- newEmptyMVar + sentVar <- forkVar (send sock2 msg (putMVar serialVar)) + receivedVar <- forkVar (receive sock1) - serial <- liftIO (takeMVar serialVar) - sent <- liftIO (takeMVar sentVar) - received <- liftIO (takeMVar receivedVar) + serial <- takeMVar serialVar + sent <- takeMVar sentVar + received <- takeMVar receivedVar - $assert (equal sent ()) - $assert (equal received (ReceivedMethodCall serial msg)) + sent @?= () + received @?= ReceivedMethodCall serial msg - -- server -> client - do - serialVar <- liftIO newEmptyMVar - sentVar <- forkVar (send sock1 msg (putMVar serialVar)) - receivedVar <- forkVar (receive sock2) + -- server -> client + do + serialVar <- newEmptyMVar + sentVar <- forkVar (send sock1 msg (putMVar serialVar)) + receivedVar <- forkVar (receive sock2) - serial <- liftIO (takeMVar serialVar) - sent <- liftIO (takeMVar sentVar) - received <- liftIO (takeMVar receivedVar) + serial <- takeMVar serialVar + sent <- takeMVar sentVar + received <- takeMVar receivedVar - $assert (equal sent ()) - $assert (equal received (ReceivedMethodCall serial msg)) + sent @?= () + received @?= ReceivedMethodCall serial msg dummyAuth :: Transport t => Authenticator t dummyAuth = authenticator diff --git a/tests/DBusTests/Transport.hs b/tests/DBusTests/Transport.hs --- a/tests/DBusTests/Transport.hs +++ b/tests/DBusTests/Transport.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2012 John Millikin -- @@ -18,62 +17,65 @@ module DBusTests.Transport (test_Transport) where -import Test.Chell - -import Control.Concurrent -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent +import Control.Monad.Extra (unlessM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource +import Data.Function (fix) +import Data.List (isInfixOf) +import Network.Socket.ByteString (sendAll, recv) +import System.Directory (getTemporaryDirectory, removeFile) +import Test.Tasty +import Test.Tasty.HUnit import qualified Data.ByteString -import Data.Function (fix) -import Data.List (isPrefixOf) import qualified Data.Map as Map -import qualified Network as N import qualified Network.Socket as NS -import Network.Socket.ByteString (sendAll, recv) -import System.Directory (getTemporaryDirectory, removeFile) -import DBus -import DBus.Transport +import DBus +import DBus.Transport -import DBusTests.Util +import DBusTests.Util -test_Transport :: Suite -test_Transport = suite "Transport" $ - suiteTests suite_TransportOpen ++ - suiteTests suite_TransportListen ++ - suiteTests suite_TransportAccept ++ - [ test_TransportSendReceive +test_Transport :: TestTree +test_Transport = testGroup "Transport" $ + [ suite_TransportOpen + , suite_TransportListen + , suite_TransportAccept + , test_TransportSendReceive , test_HandleLostConnection ] -suite_TransportOpen :: Suite -suite_TransportOpen = suite "transportOpen" $ +suite_TransportOpen :: TestTree +suite_TransportOpen = testGroup "transportOpen" $ [ test_OpenUnknown - ] ++ suiteTests suite_OpenUnix - ++ suiteTests suite_OpenTcp + , suite_OpenUnix + , suite_OpenTcp + ] -suite_TransportListen :: Suite -suite_TransportListen = suite "transportListen" $ +suite_TransportListen :: TestTree +suite_TransportListen = testGroup "transportListen" $ [ test_ListenUnknown - ] ++ suiteTests suite_ListenUnix - ++ suiteTests suite_ListenTcp + , suite_ListenUnix + , suite_ListenTcp + ] -suite_TransportAccept :: Suite -suite_TransportAccept = suite "transportAccept" +suite_TransportAccept :: TestTree +suite_TransportAccept = testGroup "transportAccept" [ test_AcceptSocket , test_AcceptSocketClosed ] -test_OpenUnknown :: Test -test_OpenUnknown = assertions "unknown" $ do +test_OpenUnknown :: TestTree +test_OpenUnknown = testCase "unknown" $ do let Just addr = address "noexist" Map.empty - $assert $ throwsEq + assertException ((transportError "Unknown address method: \"noexist\"") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) -suite_OpenUnix :: Suite -suite_OpenUnix = suite "unix" +suite_OpenUnix :: TestTree +suite_OpenUnix = testGroup "unix" [ test_OpenUnix_Path , test_OpenUnix_Abstract , test_OpenUnix_TooFew @@ -81,82 +83,80 @@ , test_OpenUnix_NotListening ] -test_OpenUnix_Path :: Test -test_OpenUnix_Path = assertions "path" $ do +test_OpenUnix_Path :: TestTree +test_OpenUnix_Path = testCase "path" $ runResourceT $ do (addr, networkSocket) <- listenRandomUnixPath - afterTest (N.sClose networkSocket) - fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr) 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) + liftIO (fdcountBefore @=? fdcountAfter) +test_OpenUnix_Abstract :: TestTree +test_OpenUnix_Abstract = testCase "abstract" $ runResourceT $ do + (addr, networkSocket, _) <- listenRandomUnixAbstract fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr) liftIO (transportClose t) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + liftIO (fdcountBefore @=? fdcountAfter) -test_OpenUnix_TooFew :: Test -test_OpenUnix_TooFew = assertions "too-few" $ do +test_OpenUnix_TooFew :: TestTree +test_OpenUnix_TooFew = testCase "too-few" $ do fdcountBefore <- countFileDescriptors let Just addr = address "unix" Map.empty - $assert $ throwsEq + assertException ((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) + fdcountBefore @=? fdcountAfter -test_OpenUnix_TooMany :: Test -test_OpenUnix_TooMany = assertions "too-many" $ do +test_OpenUnix_TooMany :: TestTree +test_OpenUnix_TooMany = testCase "too-many" $ do fdcountBefore <- countFileDescriptors let Just addr = address "unix" (Map.fromList [ ("path", "foo") , ("abstract", "bar") ]) - $assert $ throwsEq + assertException ((transportError "Only one of 'path' or 'abstract' may be specified for the 'unix' transport.") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + fdcountBefore @=? fdcountAfter -test_OpenUnix_NotListening :: Test -test_OpenUnix_NotListening = assertions "not-listening" $ do +test_OpenUnix_NotListening :: TestTree +test_OpenUnix_NotListening = testCase "not-listening" $ runResourceT $ do fdcountBefore <- countFileDescriptors - (addr, networkSocket) <- listenRandomUnixAbstract - liftIO (NS.sClose networkSocket) - $assert $ throwsEq - ((transportError "connect: does not exist (Connection refused)") - { transportErrorAddress = Just addr - }) + (addr, networkSocket, key) <- listenRandomUnixAbstract + release key + + liftIO $ assertThrows + (\err -> and + [ "Connection refused" `isInfixOf` transportErrorMessage err + , transportErrorAddress err == Just addr + ]) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + liftIO (fdcountBefore @=? fdcountAfter) -suite_OpenTcp :: Suite -suite_OpenTcp = suite "tcp" +suite_OpenTcp :: TestTree +suite_OpenTcp = testGroup "tcp" [ test_OpenTcp_IPv4 - , skipWhen noIPv6 test_OpenTcp_IPv6 + , test_OpenTcp_IPv6 , test_OpenTcp_Unknown , test_OpenTcp_NoPort , test_OpenTcp_InvalidPort @@ -164,84 +164,80 @@ , test_OpenTcp_NotListening ] -test_OpenTcp_IPv4 :: Test -test_OpenTcp_IPv4 = assertions "ipv4" $ do - (addr, networkSocket) <- listenRandomIPv4 - afterTest (N.sClose networkSocket) - +test_OpenTcp_IPv4 :: TestTree +test_OpenTcp_IPv4 = testCase "ipv4" $ runResourceT $ do + (addr, networkSocket, _) <- listenRandomIPv4 fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr) liftIO (transportClose t) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + liftIO (fdcountBefore @=? fdcountAfter) -test_OpenTcp_IPv6 :: Test -test_OpenTcp_IPv6 = assertions "ipv6" $ do +test_OpenTcp_IPv6 :: TestTree +test_OpenTcp_IPv6 = testCase "ipv6" $ unlessM noIPv6 $ runResourceT $ do (addr, networkSocket) <- listenRandomIPv6 - afterTest (N.sClose networkSocket) - fdcountBefore <- countFileDescriptors t <- liftIO (transportOpen socketTransportOptions addr) liftIO (transportClose t) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + liftIO (fdcountBefore @=? fdcountAfter) -test_OpenTcp_Unknown :: Test -test_OpenTcp_Unknown = assertions "unknown-family" $ do +test_OpenTcp_Unknown :: TestTree +test_OpenTcp_Unknown = testCase "unknown-family" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "noexist") , ("port", "1234") ]) - $assert $ throwsEq + assertException ((transportError "Unknown socket family for TCP transport: \"noexist\"") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + fdcountBefore @=? fdcountAfter -test_OpenTcp_NoPort :: Test -test_OpenTcp_NoPort = assertions "no-port" $ do +test_OpenTcp_NoPort :: TestTree +test_OpenTcp_NoPort = testCase "no-port" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") ]) - $assert $ throwsEq + assertException ((transportError "TCP transport requires the `port' parameter.") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + fdcountBefore @=? fdcountAfter -test_OpenTcp_InvalidPort :: Test -test_OpenTcp_InvalidPort = assertions "invalid-port" $ do +test_OpenTcp_InvalidPort :: TestTree +test_OpenTcp_InvalidPort = testCase "invalid-port" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "123456") ]) - $assert $ throwsEq + assertException ((transportError "Invalid socket port for TCP transport: \"123456\"") { transportErrorAddress = Just addr }) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + fdcountBefore @=? fdcountAfter -test_OpenTcp_NoUsableAddresses :: Test -test_OpenTcp_NoUsableAddresses = assertions "no-usable-addresses" $ do +test_OpenTcp_NoUsableAddresses :: TestTree +test_OpenTcp_NoUsableAddresses = testCase "no-usable-addresses" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList @@ -249,35 +245,35 @@ , ("port", "1234") , ("host", "256.256.256.256") ]) - $assert $ throws + assertThrows (\err -> and - [ "getAddrInfo: does not exist" `isPrefixOf` transportErrorMessage err + [ "getAddrInfo: does not exist" `isInfixOf` transportErrorMessage err , transportErrorAddress err == Just addr ]) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + fdcountBefore @=? fdcountAfter -test_OpenTcp_NotListening :: Test -test_OpenTcp_NotListening = assertions "too-many" $ do +test_OpenTcp_NotListening :: TestTree +test_OpenTcp_NotListening = testCase "too-many" $ runResourceT $ do fdcountBefore <- countFileDescriptors - (addr, networkSocket) <- listenRandomIPv4 - liftIO (NS.sClose networkSocket) - $assert $ throwsEq - ((transportError "connect: does not exist (Connection refused)") - { transportErrorAddress = Just addr - }) + (addr, networkSocket, key) <- listenRandomIPv4 + release key + liftIO $ assertThrows + (\err -> and + [ "Connection refused" `isInfixOf` transportErrorMessage err + , transportErrorAddress err == Just addr + ]) (transportOpen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + liftIO (fdcountBefore @=? fdcountAfter) -test_TransportSendReceive :: Test -test_TransportSendReceive = assertions "send-receive" $ do - (addr, networkSocket) <- listenRandomIPv4 - afterTest (N.sClose networkSocket) +test_TransportSendReceive :: TestTree +test_TransportSendReceive = testCase "send-receive" $ runResourceT $ do + (addr, networkSocket, _) <- listenRandomIPv4 -- a simple echo server, which sends back anything it receives. _ <- liftIO $ forkIO $ do @@ -290,8 +286,9 @@ sendAll s bytes loop - t <- liftIO (transportOpen socketTransportOptions addr) - afterTest (transportClose t) + (_, t) <- allocate + (transportOpen socketTransportOptions addr) + transportClose -- small chunks of data are combined do @@ -300,7 +297,7 @@ liftIO (transportPut t "2") liftIO (transportPut t "3") bytes <- liftIO (readMVar var) - $assert (equal bytes "123") + liftIO (bytes @?= "123") -- large chunks of data are read in full do @@ -308,35 +305,35 @@ var <- forkVar (transportGet t (4096 * 100)) liftIO (transportPut t sentBytes) bytes <- liftIO (readMVar var) - $assert (equal bytes sentBytes) + liftIO (bytes @?= sentBytes) -test_HandleLostConnection :: Test -test_HandleLostConnection = assertions "handle-lost-connection" $ do - (addr, networkSocket) <- listenRandomIPv4 - afterTest (N.sClose networkSocket) +test_HandleLostConnection :: TestTree +test_HandleLostConnection = testCase "handle-lost-connection" $ runResourceT $ do + (addr, networkSocket, _) <- listenRandomIPv4 _ <- liftIO $ forkIO $ do (s, _) <- NS.accept networkSocket sendAll s "123" NS.sClose s - t <- liftIO (transportOpen socketTransportOptions addr) - afterTest (transportClose t) + (_, t) <- allocate + (transportOpen socketTransportOptions addr) + transportClose bytes <- liftIO (transportGet t 4) - $assert (equal bytes "123") + liftIO (bytes @?= "123") -test_ListenUnknown :: Test -test_ListenUnknown = assertions "unknown" $ do +test_ListenUnknown :: TestTree +test_ListenUnknown = testCase "unknown" $ do let Just addr = address "noexist" Map.empty - $assert $ throwsEq + assertException ((transportError "Unknown address method: \"noexist\"") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) -suite_ListenUnix :: Suite -suite_ListenUnix = suite "unix" +suite_ListenUnix :: TestTree +suite_ListenUnix = testGroup "unix" [ test_ListenUnix_Path , test_ListenUnix_Abstract , test_ListenUnix_Tmpdir @@ -345,196 +342,205 @@ , test_ListenUnix_InvalidBind ] -test_ListenUnix_Path :: Test -test_ListenUnix_Path = assertions "path" $ do - path <- liftIO getTempPath +test_ListenUnix_Path :: TestTree +test_ListenUnix_Path = testCase "path" $ runResourceT $ do + (_, path) <- allocate getTempPath removeFile let Just addr = address "unix" (Map.fromList [ ("path", path) ]) - l <- liftIO (transportListen socketTransportOptions addr) - afterTest (transportListenerClose l) - afterTest (removeFile path) + (_, l) <- allocate + (transportListen socketTransportOptions addr) + transportListenerClose -- listener address is random, so it can't be checked directly. let addrParams = addressParameters (transportListenerAddress l) - $expect (sameItems (Map.keys addrParams) ["path", "guid"]) - $expect (equal (Map.lookup "path" addrParams) (Just path)) + liftIO (Map.keys addrParams @=? ["guid", "path"]) + liftIO (Map.lookup "path" addrParams @?= Just path) -test_ListenUnix_Abstract :: Test -test_ListenUnix_Abstract = assertions "abstract" $ do +test_ListenUnix_Abstract :: TestTree +test_ListenUnix_Abstract = testCase "abstract" $ runResourceT $ do path <- liftIO getTempPath let Just addr = address "unix" (Map.fromList [ ("abstract", path) ]) - l <- liftIO (transportListen socketTransportOptions addr) - afterTest (transportListenerClose l) + (_, l) <- allocate + (transportListen socketTransportOptions addr) + transportListenerClose -- listener address is random, so it can't be checked directly. let addrParams = addressParameters (transportListenerAddress l) - $expect (sameItems (Map.keys addrParams) ["abstract", "guid"]) - $expect (equal (Map.lookup "abstract" addrParams) (Just path)) + liftIO (Map.keys addrParams @?= ["abstract", "guid"]) + liftIO (Map.lookup "abstract" addrParams @?= Just path) -test_ListenUnix_Tmpdir :: Test -test_ListenUnix_Tmpdir = assertions "tmpdir" $ do +test_ListenUnix_Tmpdir :: TestTree +test_ListenUnix_Tmpdir = testCase "tmpdir" $ runResourceT $ do tmpdir <- liftIO getTemporaryDirectory let Just addr = address "unix" (Map.fromList [ ("tmpdir", tmpdir) ]) - l <- liftIO (transportListen socketTransportOptions addr) - afterTest (transportListenerClose l) + (_, l) <- allocate + (transportListen socketTransportOptions addr) + transportListenerClose -- listener address is random, so it can't be checked directly. let addrKeys = Map.keys (addressParameters (transportListenerAddress l)) - $expect ("path" `elem` addrKeys || "abstract" `elem` addrKeys) + liftIO $ assertBool "invalid keys" + ("path" `elem` addrKeys || "abstract" `elem` addrKeys) -test_ListenUnix_TooFew :: Test -test_ListenUnix_TooFew = assertions "too-few" $ do +test_ListenUnix_TooFew :: TestTree +test_ListenUnix_TooFew = testCase "too-few" $ do let Just addr = address "unix" Map.empty - $assert $ throwsEq + assertException ((transportError "One of 'abstract', 'path', or 'tmpdir' must be specified for the 'unix' transport.") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) -test_ListenUnix_TooMany :: Test -test_ListenUnix_TooMany = assertions "too-many" $ do +test_ListenUnix_TooMany :: TestTree +test_ListenUnix_TooMany = testCase "too-many" $ do let Just addr = address "unix" (Map.fromList [ ("path", "foo") , ("abstract", "bar") ]) - $assert $ throwsEq + assertException ((transportError "Only one of 'abstract', 'path', or 'tmpdir' may be specified for the 'unix' transport.") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) -test_ListenUnix_InvalidBind :: Test -test_ListenUnix_InvalidBind = assertions "invalid-bind" $ do +test_ListenUnix_InvalidBind :: TestTree +test_ListenUnix_InvalidBind = testCase "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 - }) + assertThrows + (\err -> and + [ "Address already in use" `isInfixOf` transportErrorMessage err + , transportErrorAddress err == Just addr + ]) (transportListen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + fdcountBefore @=? fdcountAfter -suite_ListenTcp :: Suite -suite_ListenTcp = suite "tcp" +suite_ListenTcp :: TestTree +suite_ListenTcp = testGroup "tcp" [ test_ListenTcp_IPv4 - , skipWhen noIPv6 test_ListenTcp_IPv6 + , test_ListenTcp_IPv6 , test_ListenTcp_Unknown , test_ListenTcp_InvalidPort , test_ListenTcp_InvalidBind ] -test_ListenTcp_IPv4 :: Test -test_ListenTcp_IPv4 = assertions "ipv4" $ do +test_ListenTcp_IPv4 :: TestTree +test_ListenTcp_IPv4 = testCase "ipv4" $ runResourceT $ do let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") ]) - l <- liftIO (transportListen socketTransportOptions addr) - afterTest (transportListenerClose l) + (_, l) <- allocate + (transportListen socketTransportOptions addr) + transportListenerClose let params = addressParameters (transportListenerAddress l) - $expect (equal (Map.lookup "family" params) (Just "ipv4")) - $expect ("port" `elem` Map.keys params) + liftIO (Map.lookup "family" params @?= Just "ipv4") + liftIO $ assertBool "no port" ("port" `elem` Map.keys params) -test_ListenTcp_IPv6 :: Test -test_ListenTcp_IPv6 = assertions "ipv6" $ do +test_ListenTcp_IPv6 :: TestTree +test_ListenTcp_IPv6 = testCase "ipv6" $ unlessM noIPv6 $ runResourceT $ do let Just addr = address "tcp" (Map.fromList [ ("family", "ipv6") ]) - l <- liftIO (transportListen socketTransportOptions addr) - afterTest (transportListenerClose l) + (_, l) <- allocate + (transportListen socketTransportOptions addr) + transportListenerClose let params = addressParameters (transportListenerAddress l) - $expect (equal (Map.lookup "family" params) (Just "ipv6")) - $expect ("port" `elem` Map.keys params) + liftIO (Map.lookup "family" params @?= Just "ipv6") + liftIO $ assertBool "no port" ("port" `elem` Map.keys params) -test_ListenTcp_Unknown :: Test -test_ListenTcp_Unknown = assertions "unknown-family" $ do +test_ListenTcp_Unknown :: TestTree +test_ListenTcp_Unknown = testCase "unknown-family" $ do let Just addr = address "tcp" (Map.fromList [ ("family", "noexist") , ("port", "1234") ]) - $assert $ throwsEq + assertException ((transportError "Unknown socket family for TCP transport: \"noexist\"") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) -test_ListenTcp_InvalidPort :: Test -test_ListenTcp_InvalidPort = assertions "invalid-port" $ do +test_ListenTcp_InvalidPort :: TestTree +test_ListenTcp_InvalidPort = testCase "invalid-port" $ do let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "123456") ]) - $assert $ throwsEq + assertException ((transportError "Invalid socket port for TCP transport: \"123456\"") { transportErrorAddress = Just addr }) (transportListen socketTransportOptions addr) -test_ListenTcp_InvalidBind :: Test -test_ListenTcp_InvalidBind = assertions "invalid-bind" $ do +test_ListenTcp_InvalidBind :: TestTree +test_ListenTcp_InvalidBind = testCase "invalid-bind" $ do fdcountBefore <- countFileDescriptors let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("port", "1") ]) - $assert $ throwsEq - ((transportError "bind: permission denied (Permission denied)") - { transportErrorAddress = Just addr - }) + assertThrows + (\err -> and + [ "Permission denied" `isInfixOf` transportErrorMessage err + , transportErrorAddress err == Just addr + ]) (transportListen socketTransportOptions addr) fdcountAfter <- countFileDescriptors - $assert (equal fdcountBefore fdcountAfter) + fdcountBefore @=? fdcountAfter -test_AcceptSocket :: Test -test_AcceptSocket = assertions "socket" $ do +test_AcceptSocket :: TestTree +test_AcceptSocket = testCase "socket" $ runResourceT $ do path <- liftIO getTempPath let Just addr = address "unix" (Map.fromList [ ("abstract", path) ]) - listener <- liftIO (transportListen socketTransportOptions addr) - afterTest (transportListenerClose listener) + (_, listener) <- allocate + (transportListen socketTransportOptions addr) + transportListenerClose acceptedVar <- forkVar (transportAccept listener) openedVar <- forkVar (transportOpen socketTransportOptions addr) - accepted <- liftIO (readMVar acceptedVar) - opened <- liftIO (readMVar openedVar) - afterTest (transportClose accepted) - afterTest (transportClose opened) + (_, accepted) <- allocate (readMVar acceptedVar) transportClose + (_, opened) <- allocate (readMVar openedVar) transportClose liftIO (transportPut opened "testing") bytes <- liftIO (transportGet accepted 7) - $expect (equal bytes "testing") + liftIO (bytes @?= "testing") -test_AcceptSocketClosed :: Test -test_AcceptSocketClosed = assertions "socket-closed" $ do - path <- liftIO getTempPath +test_AcceptSocketClosed :: TestTree +test_AcceptSocketClosed = testCase "socket-closed" $ do + path <- getTempPath let Just addr = address "unix" (Map.fromList [ ("abstract", path) ]) - listener <- liftIO (transportListen socketTransportOptions addr) + listener <- transportListen socketTransportOptions addr let listeningAddr = transportListenerAddress listener - liftIO (transportListenerClose listener) + transportListenerClose listener - $assert $ throwsEq - ((transportError "user error (accept: can't perform accept on socket ((AF_UNIX,Stream,0)) in status Closed)") - { transportErrorAddress = Just listeningAddr - }) + assertThrows + (\err -> and + [ "accept" `isInfixOf` transportErrorMessage err + , "socket" `isInfixOf` transportErrorMessage err + , "Closed" `isInfixOf` transportErrorMessage err + , transportErrorAddress err == Just listeningAddr + ]) (transportAccept listener) socketTransportOptions :: TransportOptions SocketTransport diff --git a/tests/DBusTests/Util.hs b/tests/DBusTests/Util.hs --- a/tests/DBusTests/Util.hs +++ b/tests/DBusTests/Util.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2010-2012 John Millikin -- -- This program is free software: you can redistribute it and/or modify @@ -19,6 +17,8 @@ ( assertVariant , assertValue , assertAtom + , assertException + , assertThrows , getTempPath , listenRandomUnixPath @@ -37,54 +37,52 @@ , clampedSize , smallListOf , smallListOf1 + + , DBusTests.Util.requireLeft + , DBusTests.Util.requireRight ) where -import Control.Concurrent -import Control.Exception (IOException, try, bracket, bracket_) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Bits ((.&.)) +import Control.Concurrent +import Control.Exception (Exception, IOException, try, bracket, bracket_) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource +import Data.Bits ((.&.)) +import Data.Char (chr) +import System.Directory (getTemporaryDirectory, removeFile) +import System.FilePath (()) +import Test.QuickCheck hiding ((.&.)) +import Test.Tasty.HUnit import qualified Data.ByteString import qualified Data.ByteString.Lazy -import Data.Char (chr) import qualified Data.Map as Map -import qualified Data.Set import qualified Data.Text as T import qualified Network as N import qualified Network.Socket as NS -import System.Directory (getTemporaryDirectory, removeFile) import qualified System.Posix as Posix -import System.FilePath (()) -import Test.Chell -import Test.QuickCheck hiding ((.&.)) - -import DBus -import DBus.Internal.Types +import DBus +import DBus.Internal.Types -assertVariant :: (Eq a, Show a, IsVariant a) => Type -> a -> Assertions () +assertVariant :: (Eq a, Show a, IsVariant a) => Type -> a -> Test.Tasty.HUnit.Assertion assertVariant t a = do - $expect $ equal t (variantType (toVariant a)) - $expect $ equal (fromVariant (toVariant a)) (Just a) - $expect $ equal (toVariant a) (toVariant a) - -$([d||]) + t @=? variantType (toVariant a) + Just a @=? fromVariant (toVariant a) + toVariant a @=? toVariant a -assertValue :: (Eq a, Show a, IsValue a) => Type -> a -> Assertions () +assertValue :: (Eq a, Show a, IsValue a) => Type -> a -> Test.Tasty.HUnit.Assertion assertValue t a = do - $expect $ equal t (DBus.typeOf a) - $expect $ equal t (DBus.Internal.Types.typeOf a) - $expect $ equal t (valueType (toValue a)) - $expect $ equal (fromValue (toValue a)) (Just a) - $expect $ equal (toValue a) (toValue a) + t @=? DBus.typeOf a + t @=? DBus.Internal.Types.typeOf a + t @=? valueType (toValue a) + fromValue (toValue a) @?= Just a + toValue a @=? toValue a assertVariant t a -$([d||]) - -assertAtom :: (Eq a, Show a, IsAtom a) => Type -> a -> Assertions () +assertAtom :: (Eq a, Show a, IsAtom a) => Type -> a -> Test.Tasty.HUnit.Assertion assertAtom t a = do - $expect $ equal t (atomType (toAtom a)) - $expect $ equal (fromAtom (toAtom a)) (Just a) - $expect $ equal (toAtom a) (toAtom a) + t @=? (atomType (toAtom a)) + fromAtom (toAtom a) @?= (Just a) + toAtom a @=? toAtom a assertValue t a getTempPath :: IO String @@ -93,64 +91,73 @@ uuid <- randomUUID return (tmp formatUUID uuid) -listenRandomUnixPath :: Assertions (Address, N.Socket) +listenRandomUnixPath :: MonadResource m => m (Address, N.Socket) listenRandomUnixPath = do path <- liftIO getTempPath let sockAddr = NS.SockAddrUnix path - sock <- liftIO (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) + (_, sock) <- allocate + (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) + N.sClose liftIO (NS.bindSocket sock sockAddr) liftIO (NS.listen sock 1) - afterTest (removeFile path) + _ <- register (removeFile path) let Just addr = address "unix" (Map.fromList [ ("path", path) ]) return (addr, sock) -listenRandomUnixAbstract :: MonadIO m => m (Address, N.Socket) -listenRandomUnixAbstract = liftIO $ do +listenRandomUnixAbstract :: MonadResource m => m (Address, N.Socket, ReleaseKey) +listenRandomUnixAbstract = do uuid <- liftIO randomUUID let sockAddr = NS.SockAddrUnix ('\x00' : formatUUID uuid) - sock <- NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol - NS.bindSocket sock sockAddr - NS.listen sock 1 + (key, sock) <- allocate + (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) + N.sClose + liftIO $ NS.bindSocket sock sockAddr + liftIO $ NS.listen sock 1 + let Just addr = address "unix" (Map.fromList [ ("abstract", formatUUID uuid) ]) - return (addr, sock) + return (addr, sock, key) -listenRandomIPv4 :: MonadIO m => m (Address, N.Socket) -listenRandomIPv4 = liftIO $ do - hostAddr <- NS.inet_addr "127.0.0.1" +listenRandomIPv4 :: MonadResource m => m (Address, N.Socket, ReleaseKey) +listenRandomIPv4 = do + hostAddr <- liftIO $ NS.inet_addr "127.0.0.1" let sockAddr = NS.SockAddrInet 0 hostAddr - sock <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol - NS.bindSocket sock sockAddr - NS.listen sock 1 + (key, sock) <- allocate + (NS.socket NS.AF_INET NS.Stream NS.defaultProtocol) + N.sClose + liftIO $ NS.bindSocket sock sockAddr + liftIO $ NS.listen sock 1 - sockPort <- NS.socketPort sock + sockPort <- liftIO $ NS.socketPort sock let Just addr = address "tcp" (Map.fromList [ ("family", "ipv4") , ("host", "localhost") , ("port", show (toInteger sockPort)) ]) - return (addr, sock) + return (addr, sock, key) -listenRandomIPv6 :: MonadIO m => m (Address, N.Socket) -listenRandomIPv6 = liftIO $ do - addrs <- NS.getAddrInfo Nothing (Just "::1") Nothing +listenRandomIPv6 :: MonadResource m => m (Address, N.Socket) +listenRandomIPv6 = do + addrs <- liftIO $ NS.getAddrInfo Nothing (Just "::1") Nothing let sockAddr = case addrs of [] -> error "listenRandomIPv6: no address for localhost?" a:_ -> NS.addrAddress a - sock <- NS.socket NS.AF_INET6 NS.Stream NS.defaultProtocol - NS.bindSocket sock sockAddr - NS.listen sock 1 + (_, sock) <- allocate + (NS.socket NS.AF_INET6 NS.Stream NS.defaultProtocol) + N.sClose + liftIO $ NS.bindSocket sock sockAddr + liftIO $ NS.listen sock 1 - sockPort <- NS.socketPort sock + sockPort <- liftIO $ NS.socketPort sock let Just addr = address "tcp" (Map.fromList [ ("family", "ipv6") , ("host", "::1") @@ -265,3 +272,25 @@ dropWhileEnd :: (Char -> Bool) -> String -> String dropWhileEnd p = T.unpack . T.dropWhileEnd p . T.pack + +requireLeft :: Show b => Either a b -> IO a +requireLeft (Left a) = return a +requireLeft (Right b) = assertFailure ("Right " ++ show b ++ " is not Left") >> undefined + +requireRight :: Show a => Either a b -> IO b +requireRight (Right b) = return b +requireRight (Left a) = assertFailure ("Left " ++ show a ++ " is not Right") >> undefined + +assertException :: (Eq e, Exception e) => e -> IO a -> Test.Tasty.HUnit.Assertion +assertException e f = do + result <- try f + case result of + Left ex -> ex @?= e + Right _ -> assertFailure "expected exception not thrown" + +assertThrows :: Exception e => (e -> Bool) -> IO a -> Test.Tasty.HUnit.Assertion +assertThrows check f = do + result <- try f + case result of + Left ex -> assertBool ("unexpected exception " ++ show ex) (check ex) + Right _ -> assertFailure "expected exception not thrown" diff --git a/tests/DBusTests/Variant.hs b/tests/DBusTests/Variant.hs --- a/tests/DBusTests/Variant.hs +++ b/tests/DBusTests/Variant.hs @@ -17,36 +17,35 @@ module DBusTests.Variant (test_Variant) where -import Prelude hiding (fail) - -import Test.Chell +import Test.Tasty +import Test.Tasty.HUnit +import Data.Int (Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import System.Posix.Types (Fd) import qualified Data.ByteString import qualified Data.ByteString.Lazy -import qualified Data.Text as T +import qualified Data.Map import qualified Data.Text +import qualified Data.Text as T import qualified Data.Text.Lazy -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int16, Int32, Int64) -import qualified Data.Map import qualified Data.Vector -import System.Posix.Types (Fd) -import DBus -import DBus.Internal.Types (toValue) +import DBus +import DBus.Internal.Types (toValue) -import DBusTests.Util +import DBusTests.Util -test_Variant :: Suite -test_Variant = suite "Variant" +test_Variant :: TestTree +test_Variant = testGroup "Variant" [ test_IsAtom , test_IsValue , test_Show , test_ByteStorage ] -test_IsAtom :: Test -test_IsAtom = assertions "IsAtom" $ do +test_IsAtom :: TestTree +test_IsAtom = testCase "IsAtom" $ do assertAtom TypeBoolean True assertAtom TypeWord8 (0 :: Word8) assertAtom TypeWord16 (0 :: Word16) @@ -63,8 +62,8 @@ assertAtom TypeObjectPath (objectPath_ "/") assertAtom TypeSignature (signature_ []) -test_IsValue :: Test -test_IsValue = assertions "IsValue" $ do +test_IsValue :: TestTree +test_IsValue = testCase "IsValue" $ do assertValue TypeVariant (toVariant True) assertValue (TypeArray TypeBoolean) [True] assertValue (TypeArray TypeBoolean) (Data.Vector.fromList [True]) @@ -86,70 +85,61 @@ assertValue (TypeStructure (replicate 14 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True, True) assertValue (TypeStructure (replicate 15 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True, True, True) -test_Show :: Test -test_Show = assertions "show" $ do - $expect $ equal "Variant True" (show (toVariant True)) - $expect $ equal "Variant 0" (show (toVariant (0 :: Word8))) - $expect $ equal "Variant 0" (show (toVariant (0 :: Word16))) - $expect $ equal "Variant 0" (show (toVariant (0 :: Word32))) - $expect $ equal "Variant 0" (show (toVariant (0 :: Word64))) - $expect $ equal "Variant 0" (show (toVariant (0 :: Int16))) - $expect $ equal "Variant 0" (show (toVariant (0 :: Int32))) - $expect $ equal "Variant 0" (show (toVariant (0 :: Int64))) - $expect $ equal "Variant 0.1" (show (toVariant (0.1 :: Double))) - $expect $ equal "Variant (UnixFd 1)" (show (toVariant (1 :: Fd))) - $expect $ equal "Variant \"\"" (show (toVariant (T.pack ""))) - $expect $ equal "Variant (ObjectPath \"/\")" (show (toVariant (objectPath_ "/"))) - $expect $ equal "Variant (Signature \"\")" (show (toVariant (signature_ []))) - $expect $ equal "Variant (Variant True)" (show (toVariant (toVariant True))) - $expect $ equal "Variant [True, False]" (show (toVariant [True, False])) +test_Show :: TestTree +test_Show = testCase "show" $ do + "Variant True" @=? show (toVariant True) + "Variant 0" @=? show (toVariant (0 :: Word8)) + "Variant 0" @=? show (toVariant (0 :: Word16)) + "Variant 0" @=? show (toVariant (0 :: Word32)) + "Variant 0" @=? show (toVariant (0 :: Word64)) + "Variant 0" @=? show (toVariant (0 :: Int16)) + "Variant 0" @=? show (toVariant (0 :: Int32)) + "Variant 0" @=? show (toVariant (0 :: Int64)) + "Variant 0.1" @=? show (toVariant (0.1 :: Double)) + "Variant (UnixFd 1)" @=? show (toVariant (1 :: Fd)) + "Variant \"\"" @=? show (toVariant (T.pack "")) + "Variant (ObjectPath \"/\")" @=? show (toVariant (objectPath_ "/")) + "Variant (Signature \"\")" @=? show (toVariant (signature_ [])) + "Variant (Variant True)" @=? show (toVariant (toVariant True)) + "Variant [True, False]" @=? show (toVariant [True, False]) - $expect $ equal "Variant b\"\"" (show (toVariant Data.ByteString.empty)) - $expect $ equal "Variant b\"\"" (show (toVariant Data.ByteString.Lazy.empty)) - $expect $ equal "Variant b\"\"" (show (toVariant ([] :: [Word8]))) + "Variant b\"\"" @=? show (toVariant Data.ByteString.empty) + "Variant b\"\"" @=? show (toVariant Data.ByteString.Lazy.empty) + "Variant b\"\"" @=? show (toVariant ([] :: [Word8])) - $expect $ equal "(Variant {False: True, True: False})" (showsPrec 11 (toVariant (Data.Map.fromList [(True, False), (False, True)])) "") - $expect $ equal "(Variant (True, False))" (showsPrec 11 (toVariant (True, False)) "") + "(Variant {False: True, True: False})" @=? showsPrec 11 (toVariant (Data.Map.fromList [(True, False), (False, True)])) "" + "(Variant (True, False))" @=? showsPrec 11 (toVariant (True, False)) "" -test_ByteStorage :: Test -test_ByteStorage = assertions "byte-storage" $ do +test_ByteStorage :: TestTree +test_ByteStorage = testCase "byte-storage" $ do -- Vector Word8 -> Vector Word8 - $assert $ equal - (toValue (Data.Vector.fromList [0 :: Word8])) - (toValue (Data.Vector.fromList [0 :: Word8])) + toValue (Data.Vector.fromList [0 :: Word8]) + @=? toValue (Data.Vector.fromList [0 :: Word8]) -- Vector Word8 -> ByteString - $assert $ equal - (toValue (Data.Vector.fromList [0 :: Word8])) - (toValue (Data.ByteString.pack [0])) + toValue (Data.Vector.fromList [0 :: Word8]) + @=? toValue (Data.ByteString.pack [0]) -- Vector Word8 -> Lazy.ByteString - $assert $ equal - (toValue (Data.Vector.fromList [0 :: Word8])) - (toValue (Data.ByteString.Lazy.pack [0])) + toValue (Data.Vector.fromList [0 :: Word8]) + @=? toValue (Data.ByteString.Lazy.pack [0]) -- ByteString -> Vector Word8 - $assert $ equal - (toValue (Data.ByteString.pack [0])) - (toValue (Data.Vector.fromList [0 :: Word8])) + toValue (Data.ByteString.pack [0]) + @=? toValue (Data.Vector.fromList [0 :: Word8]) -- ByteString -> ByteString - $assert $ equal - (toValue (Data.ByteString.pack [0])) - (toValue (Data.ByteString.pack [0])) + toValue (Data.ByteString.pack [0]) + @=? toValue (Data.ByteString.pack [0]) -- ByteString -> Lazy.ByteString - $assert $ equal - (toValue (Data.ByteString.pack [0])) - (toValue (Data.ByteString.Lazy.pack [0])) + toValue (Data.ByteString.pack [0]) + @=? toValue (Data.ByteString.Lazy.pack [0]) -- Lazy.ByteString -> Vector Word8 - $assert $ equal - (toValue (Data.ByteString.Lazy.pack [0])) - (toValue (Data.Vector.fromList [0 :: Word8])) + toValue (Data.ByteString.Lazy.pack [0]) + @=? toValue (Data.Vector.fromList [0 :: Word8]) -- Lazy.ByteString -> ByteString - $assert $ equal - (toValue (Data.ByteString.Lazy.pack [0])) - (toValue (Data.ByteString.pack [0])) + toValue (Data.ByteString.Lazy.pack [0]) + @=? toValue (Data.ByteString.pack [0]) -- Lazy.ByteString -> Lazy.ByteString - $assert $ equal - (toValue (Data.ByteString.Lazy.pack [0])) - (toValue (Data.ByteString.Lazy.pack [0])) + toValue (Data.ByteString.Lazy.pack [0]) + @=? toValue (Data.ByteString.Lazy.pack [0]) diff --git a/tests/DBusTests/Wire.hs b/tests/DBusTests/Wire.hs --- a/tests/DBusTests/Wire.hs +++ b/tests/DBusTests/Wire.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2012 John Millikin -- @@ -18,27 +17,29 @@ module DBusTests.Wire (test_Wire) where -import Test.Chell +import Data.Either +import Test.Tasty +import Test.Tasty.HUnit import qualified Data.ByteString.Char8 () -import DBus +import DBus -test_Wire :: Suite -test_Wire = suite "Wire" $ - suiteTests test_Unmarshal +test_Wire :: TestTree +test_Wire = testGroup "Wire" $ + [ test_Unmarshal + ] -test_Unmarshal :: Suite -test_Unmarshal = suite "unmarshal" +test_Unmarshal :: TestTree +test_Unmarshal = testGroup "unmarshal" [ test_UnmarshalUnexpectedEof ] -test_UnmarshalUnexpectedEof :: Test -test_UnmarshalUnexpectedEof = assertions "unexpected-eof" $ do +test_UnmarshalUnexpectedEof :: TestTree +test_UnmarshalUnexpectedEof = testCase "unexpected-eof" $ do let unmarshaled = unmarshal "0" - $assert (left unmarshaled) + assertBool "invalid unmarshalled parse" (isLeft unmarshaled) let Left err = unmarshaled - $assert (equal - (unmarshalErrorMessage err) - "Unexpected end of input while parsing message header.") + unmarshalErrorMessage err + @=? "Unexpected end of input while parsing message header."