d-bus-0.1.3: tests/Main.hs
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Control.Applicative ((<$>), (<*>))
import Control.Monad
import Control.Monad.Reader
import DBus.Signature
import Data.Binary.Get
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Builder as BS
import Data.Char
import Data.Either
import Data.Int
import Data.List (intercalate)
import Data.Singletons
import Data.Singletons.Prelude.List
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Word
import DBus.Types
import DBus.Wire
-- import DBus.Introspect
import Test.QuickCheck
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Numeric
import Debug.Trace
instance Arbitrary DBusSimpleType where
arbitrary = oneof [ return TypeByte
, return TypeBoolean
, return TypeInt16
, return TypeUInt16
, return TypeInt32
, return TypeUInt32
, return TypeInt64
, return TypeUInt64
, return TypeDouble
, return TypeUnixFD
, return TypeString
, return TypeObjectPath
, return TypeSignature
]
shrink _ = [TypeByte]
resized :: Gen a -> Gen a
resized g = sized (\i -> resize (i `div` 2) g)
maxsized :: Int -> Gen a -> Gen a
maxsized s g = sized (\i -> resize (min s i) g)
instance Arbitrary DBusType where
arbitrary = oneof [ DBusSimpleType <$> resized arbitrary
, TypeArray <$> resized arbitrary
, TypeStruct <$> resized (listOf1 arbitrary)
, TypeDict <$> resized arbitrary <*> resized arbitrary
, return TypeVariant
]
shrink (TypeStruct ts) = TypeStruct <$> (filter (not.null) $ shrink ts)
shrink (TypeDict kt vt) = (TypeDict kt <$> (shrink vt))
++ (TypeDict <$> (shrink kt) <*> [vt])
shrink (TypeDictEntry kt vt) = (TypeDictEntry kt <$> (shrink vt))
++ (TypeDictEntry <$> (shrink kt) <*> [vt])
shrink (TypeArray t) = TypeArray <$> shrink t
shrink t = []
prop_signatureInverse = \s -> eitherParseSig (toSignature s) == Right s
nodeXml = Text.encodeUtf8 $ Text.concat
[ "<!DOCTYPE node PUBLIC \"-//freedesktop//DTD D-BUS Object Introspection \
\1.0//EN\""
, " \"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd\">"
, " <node name=\"/com/example/sample_object\">"
, " <interface name=\"com.example.SampleInterface\">"
, " <method name=\"Frobate\">"
, " <arg name=\"foo\" type=\"i\" direction=\"in\"/>"
, " <arg name=\"bar\" type=\"s\" direction=\"out\"/>"
, " <arg name=\"baz\" type=\"a{us}\" direction=\"out\"/>"
, " <annotation name=\"org.freedesktop.DBus.Deprecated\" value=\"true\"/>"
, " </method>"
, " <method name=\"Bazify\">"
, " <arg name=\"bar\" type=\"(iiu)\" direction=\"in\"/>"
, " <arg name=\"bar\" type=\"v\" direction=\"out\"/>"
, " </method>"
, " <method name=\"Mogrify\">"
, " <arg name=\"bar\" type=\"(iiav)\" direction=\"in\"/>"
, " </method>"
, " <signal name=\"Changed\">"
, " <arg name=\"new_value\" type=\"b\"/>"
, " </signal>"
, " <property name=\"Bar\" type=\"y\" access=\"readwrite\"/>"
, " </interface>"
, " <node name=\"child_of_sample_object\"/>"
, " <node name=\"another_child_of_sample_object\"/>"
, "</node>"
]
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight (Left _) = False
-- testing_pickler1 = isRight $ xmlToNode nodeXml
-- testing_pickler2 = let Right node = xmlToNode nodeXml
-- reXml = nodeToXml node
-- Right reNode = xmlToNode reXml
-- in node == reNode
genText = Text.pack <$> arbitrary
genOP = objectPath . Text.pack <$> arbitrary
shrinkTypes [x] = (:[]) <$> shrinkType x
shrinkTypes xs = if BS.length (toSignatures xs) > 255
then shrinkTypes (tail xs)
else return xs
genDBV :: Sing t -> Gen (DBusValue t)
genDBV (SDBusSimpleType STypeByte) = DBVByte <$> arbitrary
genDBV (SDBusSimpleType STypeBoolean) = DBVBool <$> arbitrary
genDBV (SDBusSimpleType STypeInt16) = DBVInt16 <$> arbitrary
genDBV (SDBusSimpleType STypeUInt16) = DBVUInt16 <$> arbitrary
genDBV (SDBusSimpleType STypeInt32) = DBVInt32 <$> arbitrary
genDBV (SDBusSimpleType STypeUInt32) = DBVUInt32 <$> arbitrary
genDBV (SDBusSimpleType STypeInt64) = DBVInt64 <$> arbitrary
genDBV (SDBusSimpleType STypeUInt64) = DBVUInt64 <$> arbitrary
genDBV (SDBusSimpleType STypeDouble) = DBVDouble <$> arbitrary
genDBV (SDBusSimpleType STypeUnixFD) = DBVUnixFD <$> arbitrary
genDBV (SDBusSimpleType STypeString) = DBVString <$> genText
genDBV (SDBusSimpleType STypeObjectPath) = DBVObjectPath <$> genOP
genDBV (SDBusSimpleType STypeSignature) = maxsized 10 $
DBVSignature <$> (shrinkTypes =<< arbitrary)
genDBV STypeVariant = resized $ do
t <- maxsized 10 $ shrinkType =<< arbitrary :: Gen DBusType
case toSing t of
SomeSing (st :: Sing t) -> withSingI st $ DBVVariant <$> genDBV st
genDBV (STypeArray t) = resized $ DBVArray
<$> listOf (genDBV t)
genDBV (STypeStruct ts) = resized $ DBVStruct <$> genStruct ts
genDBV (STypeDict kt vt) = resized $
DBVDict <$> listOf ((,) <$> genDBV (SDBusSimpleType kt)
<*> genDBV vt)
genStruct :: Sing ts -> Gen (DBusStruct ts)
genStruct (SCons t SNil) = StructSingleton <$> genDBV t
genStruct (SCons t ts) = StructCons <$> genDBV t <*> genStruct ts
for = flip map
shrinkType t = if BS.length (toSignature t) > 255
then shrinkType =<< elements (shrink t)
else return t
instance Arbitrary SomeDBusValue where
arbitrary = do
t <- shrinkType =<< arbitrary :: Gen DBusType
case toSing t of
SomeSing st -> withSingI st $ DBV <$> genDBV st
shrink (DBV x) = case x of
DBVVariant y -> (DBV y)
: ((\(DBV x) -> DBV (DBVVariant x)) <$> shrink (DBV y))
(DBVArray (a:as) :: DBusValue t) -> case (sing :: Sing t) of
STypeArray ts -> withSingI ts $
( case shrink (fromSing (sing :: Sing t)) of
tss -> for tss $ \tshrink -> case toSing tshrink of
(SomeSing (ss :: Sing (tt :: DBusType)))
-> withSingI ss $
DBV (DBVArray ([] :: [DBusValue tt]))
) ++
[ DBV ( DBVArray [] :: DBusValue t)
, DBV ( DBVArray as :: DBusValue t)
, DBV ( DBVArray (init (a:as)) :: DBusValue t)
, case (sing :: Sing t) of
STypeArray st
-> withSingI st $ DBV a
] ++ map (\(DBV b) -> DBV (DBVArray [b])) (shrink (DBV a))
(DBVDict ((k,v):as) :: DBusValue t)
-> [ DBV ( DBVDict [] :: DBusValue t)
, DBV ( DBVDict as :: DBusValue t)
, case (sing :: Sing t) of
STypeDict kt vt -> withSingI kt $ DBV k
, case (sing :: Sing t) of
STypeDict kt vt -> withSingI vt $ DBV v
]
(DBVStruct fs :: DBusValue t) ->
case (sing :: Sing t) of
STypeStruct ts -> shrinkStruct ts fs
_ -> []
shrinkStruct :: Sing ts -> DBusStruct ts -> [SomeDBusValue]
shrinkStruct (SCons t SNil) (StructSingleton x) = withSingI t [DBV x]
shrinkStruct (SCons t ts) (StructCons x xs) =
withSingI t $ withSingI ts $
(DBV $ DBVStruct xs)
: (DBV x)
: (shrinkStruct ts xs)
hexifyChar c = case showHex c "" of
[x] -> ['0',x]
x -> x
hexifyBS bs = intercalate " " $ hexifyChar <$> BSL.unpack bs
showifyChar c = if ord 'a' <= c && c <= ord 'z'
then chr c : " "
else " "
showifyBS bs = intercalate " " $ showifyChar . fromIntegral <$> BSL.unpack bs
-- sho bs = "============\n" ++ show bs ++ "\n -------------- \n" ++ hexifyBS bs
sho bs = show bs
to :: SingI t => DBusValue t -> BSL.ByteString
to x = (BS.toLazyByteString $ runDBusPut Big (putDBV x))
wire_inverse (x :: DBusValue t) =
let from = runGet (runReaderT getDBV Big) (to x)
in (DBV from, x == from)
prop_wire_inverse (DBV x) = snd $ wire_inverse x
main = $defaultMainGenerator
ppv (x :: DBusValue t) = do
print x
let bs = to x
return $! bs
forM_ [1..32] $ \i -> (putStr $ hexifyChar i) >> putStr " "
putStrLn ""
putStrLn (hexifyBS bs)
putStrLn (showifyBS bs)
putStrLn (" ## " ++ show (BSL.length bs))
let from = runGet (runReaderT getDBV Big) bs
print from
print x
print $ x == from
foo = sample' arbitrary >>= (mapM_ $ \(DBV x) -> ppv x)
test1 = DBVVariant (DBVArray [DBVUInt16 2])
test2 = DBVArray [DBVByte 0 , DBVByte 3, DBVByte 0]
test3 = DBVVariant (DBVVariant (DBVStruct (StructSingleton (DBVStruct (StructSingleton (DBVUInt16 9))))))
test4 = DBVArray [DBVVariant $ DBVUInt32 7 ]
test5 = DBVArray [DBVVariant $ DBVUInt64 7 ]
test6 = DBVArray [DBVStruct (StructSingleton (DBVVariant (DBVUInt32 0)))]
test7 = DBVArray [DBVStruct (StructSingleton (DBVUInt64 (maxBound :: Word64)))]
test8o = DBVVariant (DBVVariant (DBVArray [DBVVariant (DBVVariant (DBVInt16 (-1)))]))
test8 = DBVVariant (DBVVariant (DBVArray [DBVVariant (DBVVariant (DBVInt16 (-1)))]))