% 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 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