dbus-core-0.8.1: hs/Tests.hs
{-
Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE OverloadedStrings #-}
module Main (tests) where
import Test.QuickCheck
import Test.Framework (Test, testGroup)
import qualified Test.Framework as F
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Control.Arrow ((&&&))
import Control.Monad (replicateM)
import qualified Data.Binary.Get as G
import Data.Char (isPrint)
import Data.List (intercalate, isInfixOf)
import Data.Maybe (fromJust, isJust, isNothing)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)
import DBus.Address
import DBus.Message.Internal
import DBus.Types
import DBus.Wire.Internal
import DBus.Wire.Marshal
import DBus.Wire.Unmarshal
import qualified DBus.Introspection as I
tests :: [Test]
tests = [ testGroup "Types"
[ testGroup "Atomic types"
[
testGroup "Bool" $ commonVariantTests (arbitrary :: Gen Bool)
, testGroup "Word8" $ commonVariantTests (arbitrary :: Gen Word8)
, testGroup "Word16" $ commonVariantTests (arbitrary :: Gen Word16)
, testGroup "Word32" $ commonVariantTests (arbitrary :: Gen Word32)
, testGroup "Word64" $ commonVariantTests (arbitrary :: Gen Word64)
, testGroup "Int16" $ commonVariantTests (arbitrary :: Gen Int16)
, testGroup "Int32" $ commonVariantTests (arbitrary :: Gen Int32)
, testGroup "Int64" $ commonVariantTests (arbitrary :: Gen Int64)
, testGroup "Double" $ commonVariantTests (arbitrary :: Gen Double)
, testGroup "String" $ commonVariantTests (arbitrary :: Gen String) ++
[ testProperty "String -> strict Text"
$ \x -> (fromVariant . toVariant) x == (Just $ T.pack x)
, testProperty "String <- strict Text"
$ \x -> (fromVariant . toVariant) x == (Just $ T.unpack x)
, testProperty "String -> lazy Text"
$ \x -> (fromVariant . toVariant) x == (Just $ TL.pack x)
, testProperty "String <- lazy Text"
$ \x -> (fromVariant . toVariant) x == (Just $ TL.unpack x)
, testProperty "Strict Text -> lazy Text"
$ \x -> (fromVariant . toVariant) x == (Just $ TL.pack . T.unpack $ x)
, testProperty "Strict Text <- lazy Text"
$ \x -> (fromVariant . toVariant) x == (Just $ T.pack . TL.unpack $ x)
]
, testGroup "Signature" $ commonVariantTests (arbitrary :: Gen Signature) ++
[ testProperty "Signature identity"
$ \x -> (mkSignature . strSignature) x == Just x
, testProperty "Signature show"
$ \x -> show (strSignature x) `isInfixOf` show x
]
, testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) ++
[ testProperty "ObjectPath identity"
$ \x -> (mkObjectPath . strObjectPath) x == Just x
]
, testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) ++
[ testProperty "BusName identity"
$ \x -> (mkBusName . strBusName) x == Just x
]
, testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) ++
[ testProperty "InterfaceName identity"
$ \x -> (mkInterfaceName . strInterfaceName) x == Just x
]
, testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++
[ testProperty "ErrorName identity"
$ \x -> (mkErrorName . strErrorName) x == Just x
]
, testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) ++
[ testProperty "MemberName identity"
$ \x -> (mkMemberName . strMemberName) x == Just x
]
]
, testGroup "Container types"
[
testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant)
, testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) ++
[ testProperty "Array identity"
$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x)
, testProperty "Array homogeneity" prop_ArrayHomogeneous
]
, testGroup "Dictionary" $ commonVariantTests (arbitrary :: Gen Dictionary) ++
[ testProperty "Dictionary identity"
$ \x -> Just x == dictionaryFromItems
(dictionaryKeyType x)
(dictionaryValueType x)
(dictionaryItems x)
, testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous
, testProperty "Dictionary must have atomic keys"
$ \vt -> forAll containerType $ \kt ->
isNothing (dictionaryFromItems kt vt [])
, testProperty "Dictionary <-> Array conversion"
$ \x -> arrayToDictionary (dictionaryToArray x) == Just x
]
, testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure)
]
]
, testGroup "Addresses"
[ testProperty "Address identity"
$ \x -> mkAddresses (strAddress x) == Just [x]
, testProperty "Multiple addresses"
$ \x y -> let
joined = TL.concat [strAddress x, ";", strAddress y]
in mkAddresses joined == Just [x, y]
, testProperty "Ignore trailing semicolon"
$ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x]
, testProperty "Ignore trailing comma"
$ \x -> let
hasParams = not . Map.null . addressParameters $ x
parsed = mkAddresses (TL.append (strAddress x) ",")
in hasParams ==> parsed == Just [x]
, testGroup "Valid addresses" $ singleTests
[ isJust . mkAddresses $ ":"
, isJust . mkAddresses $ "a:"
, isJust . mkAddresses $ "a:b=c"
, isJust . mkAddresses $ "a:;"
, isJust . mkAddresses $ "a:;b:"
, isJust . mkAddresses $ "a:b=c,"
]
, testGroup "Invalid addresses" $ singleTests
[ isNothing . mkAddresses $ ""
, isNothing . mkAddresses $ "a"
, isNothing . mkAddresses $ "a:b"
, isNothing . mkAddresses $ "a:b="
, isNothing . mkAddresses $ "a:,"
]
]
, testGroup "Wire format"
[ testProperty "Marshal -> Ummarshal" prop_Unmarshal
, testGroup "Messages"
[ testProperty "Method calls" prop_WireMethodCall
, testProperty "Method returns" prop_WireMethodReturn
, testProperty "Errors" prop_WireError
, testProperty "Signals" prop_WireSignal
]
]
, testGroup "Introspection"
[ testProperty "Generate -> Parse"
$ \x@(I.Object path _ _) -> let
xml = I.toXML x
Just xml' = xml
parsed = I.fromXML path xml'
in isJust xml ==> I.fromXML path xml' == Just x
]
]
main :: IO ()
main = F.defaultMain tests
atomicType :: Gen Type
atomicType = elements
[ DBusBoolean
, DBusByte
, DBusWord16
, DBusWord32
, DBusWord64
, DBusInt16
, DBusInt32
, DBusInt64
, DBusDouble
, DBusString
, DBusObjectPath
, DBusSignature
]
containerType :: Gen Type
containerType = do
c <- choose (0,3) :: Gen Int
case c of
0 -> fmap DBusArray arbitrary
1 -> do
kt <- atomicType
vt <- arbitrary
return $ DBusDictionary kt vt
2 -> fmap DBusStructure $ shrinkingGen arbitrary
3 -> return DBusVariant
instance Arbitrary Type where
arbitrary = oneof [atomicType, containerType]
instance Arbitrary Signature where
arbitrary = clampedSize 255 genSig mkSignature_ where
genSig = fmap (TL.concat . map typeCode) arbitrary
instance Arbitrary ObjectPath where
arbitrary = fmap (mkObjectPath_ . TL.pack) path' where
c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
path = fmap (intercalate "/" . ([] :)) genElements
path' = frequency [(1, return "/"), (9, path)]
genElements = sized' 1 (sized' 1 (elements c))
instance Arbitrary BusName where
arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName_ where
c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"
c' = c ++ ['0'..'9']
unique = do
elems' <- sized' 2 $ elems c'
return . TL.pack $ ':' : intercalate "." elems'
wellKnown = do
elems' <- sized' 2 $ elems c
return . TL.pack $ intercalate "." elems'
elems start = do
x <- elements start
xs <- sized' 0 (elements c')
return (x:xs)
instance Arbitrary InterfaceName where
arbitrary = clampedSize 255 genName mkInterfaceName_ where
c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
c' = c ++ ['0'..'9']
genName = fmap (TL.pack . intercalate ".") genElements
genElements = sized' 2 genElement
genElement = do
x <- elements c
xs <- sized' 0 (elements c')
return (x:xs)
instance Arbitrary ErrorName where
arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary
instance Arbitrary MemberName where
arbitrary = clampedSize 255 genName mkMemberName_ where
c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
c' = c ++ ['0'..'9']
genName = do
x <- elements c
xs <- sized' 0 (elements c')
return . TL.pack $ (x:xs)
prop_VariantIdentity gen = testProperty "Variant identity" . forAll gen
$ \x -> (fromVariant . toVariant) x == Just x
prop_VariantEquality gen = testProperty "Variant equality" . forAll gen
$ \x y -> (x == y) == (toVariant x == toVariant y)
commonVariantTests gen =
[ prop_VariantIdentity gen
, prop_VariantEquality gen
]
genVariant :: Type -> Gen Variant
genVariant DBusBoolean = fmap toVariant (arbitrary :: Gen Bool)
genVariant DBusByte = fmap toVariant (arbitrary :: Gen Word8)
genVariant DBusWord16 = fmap toVariant (arbitrary :: Gen Word16)
genVariant DBusWord32 = fmap toVariant (arbitrary :: Gen Word32)
genVariant DBusWord64 = fmap toVariant (arbitrary :: Gen Word64)
genVariant DBusInt16 = fmap toVariant (arbitrary :: Gen Int16)
genVariant DBusInt32 = fmap toVariant (arbitrary :: Gen Int32)
genVariant DBusInt64 = fmap toVariant (arbitrary :: Gen Int64)
genVariant DBusDouble = fmap toVariant (arbitrary :: Gen Double)
genVariant DBusString = fmap toVariant (arbitrary :: Gen String)
genVariant DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath)
genVariant DBusSignature = fmap toVariant (arbitrary :: Gen Signature)
genVariant (DBusArray _) = fmap toVariant (arbitrary :: Gen Array)
genVariant (DBusDictionary _ _) = fmap toVariant (arbitrary :: Gen Dictionary)
genVariant (DBusStructure _) = fmap toVariant (arbitrary :: Gen Structure)
genVariant DBusVariant = fmap toVariant (arbitrary :: Gen Variant)
instance Arbitrary Variant where
arbitrary = arbitrary >>= genVariant
genAtom :: Type -> Gen Variant
genAtom DBusBoolean = fmap toVariant (arbitrary :: Gen Bool)
genAtom DBusByte = fmap toVariant (arbitrary :: Gen Word8)
genAtom DBusWord16 = fmap toVariant (arbitrary :: Gen Word16)
genAtom DBusWord32 = fmap toVariant (arbitrary :: Gen Word32)
genAtom DBusWord64 = fmap toVariant (arbitrary :: Gen Word64)
genAtom DBusInt16 = fmap toVariant (arbitrary :: Gen Int16)
genAtom DBusInt32 = fmap toVariant (arbitrary :: Gen Int32)
genAtom DBusInt64 = fmap toVariant (arbitrary :: Gen Int64)
genAtom DBusDouble = fmap toVariant (arbitrary :: Gen Double)
genAtom DBusString = fmap toVariant (arbitrary :: Gen String)
genAtom DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath)
genAtom DBusSignature = fmap toVariant (arbitrary :: Gen Signature)
instance Arbitrary Array where
arbitrary = do
-- Only generate arrays of atomic values, as generating
-- containers randomly almost never results in a valid
-- array.
t <- atomicType
xs <- listOf $ genVariant t
return . fromJust $ arrayFromItems t xs
prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where
array = arrayFromItems firstType vs
homogeneousTypes = all (== firstType) types
types = map variantType vs
firstType = if null types
then DBusByte
else head types
instance Arbitrary Dictionary where
arbitrary = do
-- Only generate dictionaries of atomic values, as generating
-- containers randomly almost never results in a valid
-- dictionary.
kt <- atomicType
vt <- atomicType
ks <- listOf $ genAtom kt
vs <- vectorOf (length ks) $ genVariant vt
return . fromJust $ dictionaryFromItems kt vt $ zip ks vs
prop_DictionaryHomogeneous x = all correctType pairs where
pairs = dictionaryItems x
kType = dictionaryKeyType x
vType = dictionaryValueType x
correctType (k, v) = variantType k == kType &&
variantType v == vType
instance Arbitrary Structure where
arbitrary = sized $ \n ->
fmap Structure $ shrinkingGen arbitrary
singleTests :: Testable a => [a] -> [Test]
singleTests ts = singleTests' 1 ts where
singleTests' _ [] = []
singleTests' n (t:ts') = plusOptions (testProperty (name n) t)
: singleTests' (n + 1) ts'
total = length ts
options = F.TestOptions Nothing (Just 1) Nothing Nothing
plusOptions = F.plusTestOptions options
name n = "Test " ++ show n ++ "/" ++ show total
instance Arbitrary Address where
arbitrary = genAddress where
optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."
methodChars = filter (flip notElem ":;") ['!'..'~']
keyChars = filter (flip notElem "=;,") ['!'..'~']
genMethod = sized' 0 $ elements methodChars
genParam = do
key <- genKey
value <- genValue
return . concat $ [key, "=", value]
genKey = sized' 1 $ elements keyChars
genValue = oneof [encodedValue, plainValue]
genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']
encodedValue = do
x1 <- genHex
x2 <- genHex
return ['%', x1, x2]
plainValue = sized' 1 $ elements optional
genParams = do
params <- sized' 0 genParam
let params' = intercalate "," params
extraComma <- if null params
then return ""
else elements ["", ","]
return $ concat [params', extraComma]
genAddress = do
m <- genMethod
params <- genParams
extraSemicolon <- elements ["", ";"]
let addrStr = concat [m, ":", params, extraSemicolon]
let Just [addr] = mkAddresses $ TL.pack addrStr
return addr
instance Arbitrary Serial where
arbitrary = fmap Serial arbitrary
instance Arbitrary Flag where
arbitrary = elements [NoReplyExpected, NoAutoStart]
instance Arbitrary MethodCall where
arbitrary = do
path <- arbitrary
member <- arbitrary
iface <- arbitrary
dest <- arbitrary
flags <- fmap Set.fromList arbitrary
Structure body <- arbitrary
return $ MethodCall path member iface dest flags body
instance Arbitrary MethodReturn where
arbitrary = do
serial <- arbitrary
dest <- arbitrary
Structure body <- arbitrary
return $ MethodReturn serial dest body
instance Arbitrary Error where
arbitrary = do
name <- arbitrary
serial <- arbitrary
dest <- arbitrary
Structure body <- arbitrary
return $ Error name serial dest body
instance Arbitrary Signal where
arbitrary = do
path <- arbitrary
member <- arbitrary
iface <- arbitrary
dest <- arbitrary
Structure body <- arbitrary
return $ Signal path member iface dest body
isRight :: Either a b -> Bool
isRight = either (const False) (const True)
prop_Unmarshal :: Endianness -> Variant -> Property
prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where
sig = mkSignature . typeCode . variantType $ x
Just sig' = sig
bytes = runMarshal (marshal x) e
Right bytes' = bytes
valid = isJust sig && isRight bytes
unmarshaled = runUnmarshal (unmarshal sig') e bytes'
prop_MarshalMessage e serial msg expected = valid ==> correct where
bytes = marshalMessage e serial msg
Right bytes' = bytes
getBytes = G.getLazyByteString . fromIntegral
unmarshaled = G.runGet (unmarshalMessage getBytes) bytes'
valid = isRight bytes
correct = unmarshaled == Right expected
prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg
$ ReceivedMethodCall serial Nothing msg
prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg
$ ReceivedMethodReturn serial Nothing msg
prop_WireError e serial msg = prop_MarshalMessage e serial msg
$ ReceivedError serial Nothing msg
prop_WireSignal e serial msg = prop_MarshalMessage e serial msg
$ ReceivedSignal serial Nothing msg
instance Arbitrary Endianness where
arbitrary = elements [LittleEndian, BigEndian]
subObject :: ObjectPath -> Gen I.Object
subObject parentPath = sized $ \n -> resize (min n 4) $ do
let nonRoot = do
x <- arbitrary
case strObjectPath x of
"/" -> nonRoot
x' -> return x'
thisPath <- nonRoot
let path' = case strObjectPath parentPath of
"/" -> thisPath
x -> TL.append x thisPath
let path = mkObjectPath_ path'
ifaces <- arbitrary
children <- shrinkingGen . listOf . subObject $ path
return $ I.Object path ifaces children
instance Arbitrary I.Object where
arbitrary = arbitrary >>= subObject
instance Arbitrary I.Interface where
arbitrary = do
name <- arbitrary
methods <- arbitrary
signals <- arbitrary
properties <- arbitrary
return $ I.Interface name methods signals properties
instance Arbitrary I.Method where
arbitrary = do
name <- arbitrary
inParams <- arbitrary
outParams <- arbitrary
return $ I.Method name inParams outParams
instance Arbitrary I.Signal where
arbitrary = do
name <- arbitrary
params <- arbitrary
return $ I.Signal name params
singleType :: Gen Signature
singleType = do
t <- arbitrary
case mkSignature $ typeCode t of
Just x -> return x
Nothing -> singleType
instance Arbitrary I.Parameter where
arbitrary = do
name <- listOf $ arbitrary `suchThat` isPrint
sig <- singleType
return $ I.Parameter (TL.pack name) sig
instance Arbitrary I.Property where
arbitrary = do
name <- listOf $ arbitrary `suchThat` isPrint
sig <- singleType
access <- elements
[[], [I.Read], [I.Write],
[I.Read, I.Write]]
return $ I.Property (TL.pack name) sig access
iexp :: Integral a => a -> a -> a
iexp x y = floor $ fromIntegral x ** fromIntegral y
instance Arbitrary Word8 where
arbitrary = fmap fromIntegral gen where
gen = choose (0, max') :: Gen Integer
max' = iexp 2 8 - 1
instance Arbitrary Word16 where
arbitrary = fmap fromIntegral gen where
gen = choose (0, max') :: Gen Integer
max' = iexp 2 16 - 1
instance Arbitrary Word32 where
arbitrary = fmap fromIntegral gen where
gen = choose (0, max') :: Gen Integer
max' = iexp 2 32 - 1
instance Arbitrary Word64 where
arbitrary = fmap fromIntegral gen where
gen = choose (0, max') :: Gen Integer
max' = iexp 2 64 - 1
instance Arbitrary Int16 where
arbitrary = fmap fromIntegral gen where
gen = choose (0, max') :: Gen Integer
max' = iexp 2 16 - 1
instance Arbitrary Int32 where
arbitrary = fmap fromIntegral gen where
gen = choose (0, max') :: Gen Integer
max' = iexp 2 32 - 1
instance Arbitrary Int64 where
arbitrary = fmap fromIntegral gen where
gen = choose (0, max') :: Gen Integer
max' = iexp 2 64 - 1
instance Arbitrary T.Text where
arbitrary = fmap T.pack arbitrary
instance Arbitrary TL.Text where
arbitrary = fmap TL.pack arbitrary
sized' :: Int -> Gen a -> Gen [a]
sized' atLeast g = sized $ \n -> do
n' <- choose (atLeast, max atLeast n)
replicateM n' g
clampedSize :: Arbitrary a => Int64 -> Gen TL.Text -> (TL.Text -> a) -> Gen a
clampedSize maxSize gen f = do
s <- gen
if TL.length s > maxSize
then shrinkingGen arbitrary
else return . f $ s
shrinkingGen :: Gen a -> Gen a
shrinkingGen gen = sized $ \n -> if n > 0 then
resize (n `div` 2) gen
else gen