% 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