% 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/>.
<<Tests.hs>>=
<<copyright>>
{-# 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
@ \section{Tests}
<<Tests.hs>>=
tests :: [Test]
tests = [<<tests>>
]
main :: IO ()
main = F.defaultMain tests
@ \subsection{Types}
<<tests>>=
testGroup "Types"
[ testGroup "Atomic types"
[<<atom tests>>
]
, testGroup "Container types"
[<<container tests>>
]
]
<<atom tests>>=
<<container tests>>=
@ \subsubsection{Atoms}
<<atom tests>>=
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)
]
<<Tests.hs>>=
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
<<atom tests>>=
, 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
]
<<Tests.hs>>=
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))
<<atom tests>>=
, testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) ++
[ testProperty "ObjectPath identity"
$ \x -> (mkObjectPath . strObjectPath) x == Just x
]
<<Tests.hs>>=
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)
<<atom tests>>=
, testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) ++
[ testProperty "BusName identity"
$ \x -> (mkBusName . strBusName) x == Just x
]
<<Tests.hs>>=
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)
<<atom tests>>=
, testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) ++
[ testProperty "InterfaceName identity"
$ \x -> (mkInterfaceName . strInterfaceName) x == Just x
]
<<Tests.hs>>=
instance Arbitrary ErrorName where
arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary
<<atom tests>>=
, testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) ++
[ testProperty "ErrorName identity"
$ \x -> (mkErrorName . strErrorName) x == Just x
]
<<Tests.hs>>=
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)
<<atom tests>>=
, testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) ++
[ testProperty "MemberName identity"
$ \x -> (mkMemberName . strMemberName) x == Just x
]
@ \subsubsection{Containers}
@ All variable types must obey these properties.
<<Tests.hs>>=
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)
@ Since all atomic types are also variable, the Variant properties are
added to the set of common Atom tests.
<<common atom tests>>=
, prop_VariantIdentity gen
, prop_VariantEquality gen
<<Tests.hs>>=
commonVariantTests gen =
[ prop_VariantIdentity gen
, prop_VariantEquality gen
]
<<Tests.hs>>=
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
<<Tests.hs>>=
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)
<<container tests>>=
testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant)
<<Tests.hs>>=
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
<<container tests>>=
, testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) ++
[ testProperty "Array identity"
$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x)
, testProperty "Array homogeneity" prop_ArrayHomogeneous
]
<<Tests.hs>>=
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
<<container tests>>=
, 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
]
<<Tests.hs>>=
instance Arbitrary Structure where
arbitrary = sized $ \n ->
fmap Structure $ shrinkingGen arbitrary
<<container tests>>=
, testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure)
@ \subsection{Addresses}
<<Tests.hs>>=
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
<<tests>>=
, 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:,"
]
]
<<Tests.hs>>=
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
@ \subsection{Messages}
<<Tests.hs>>=
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
@ \subsection{Wire format}
<<Tests.hs>>=
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
<<tests>>=
, 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
]
]
<<Tests.hs>>=
instance Arbitrary Endianness where
arbitrary = elements [LittleEndian, BigEndian]
@ \subsection{Introspection}
<<tests>>=
, 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
]
<<Tests.hs>>=
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
@ \subsection{Other instances}
<<Tests.hs>>=
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