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