dbus-core-0.9.2: tests/DBus/Tests.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- Copyright (C) 2010-2011 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/>.
module DBus.Tests (tests) where
import Prelude hiding (fail)
import Test.Chell
import Test.Chell.QuickCheck
import Test.QuickCheck hiding ((.&.), property)
import Control.Applicative ((<$>), (<*>))
import qualified Control.Exception
import Control.Monad (liftM, liftM2)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Binary.Builder
import Data.Bits ((.&.))
import Data.ByteString (ByteString)
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import Data.Char (chr)
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text
import qualified Data.Text.Lazy
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)
import Data.Map (Map)
import qualified Data.Map
import Data.Maybe (isJust, fromJust)
import qualified Data.Set
import Data.String (IsString, fromString)
import qualified Data.Vector
import qualified System.Posix.Env
import DBus.Address
import DBus.Client ()
import DBus.Client.Simple ()
import DBus.Connection ()
import DBus.Message ()
import DBus.Message.Internal hiding (errorName)
import DBus.Types
import DBus.Types.Internal
import DBus.Wire (marshalMessage, unmarshalMessage)
import qualified DBus.Wire
import qualified DBus.Wire.Internal
import qualified DBus.Introspection
import DBus.Tests.Util
tests :: [Suite]
tests = [ suite_Address
, suite_Signature
, suite_Types
, suite_Variant
, suite_ObjectPath
, suite_ContainerBoxes
, suite_InterfaceName
, suite_MemberName
, suite_ErrorName
, suite_BusName
, suite_Wire
, suite_Introspection
]
suite_Address :: Suite
suite_Address = suite "address"
[ suite "valid"
[ test $ assertions "colon" $ do
let m_addr = address ":"
$assert $ just m_addr
let Just addr = m_addr
$expect $ equal (addressMethod addr) ""
$expect $ equal (addressParameters addr) (Data.Map.fromList [])
, test $ assertions "just-scheme" $ do
addr <- requireJust (address "a:")
$expect $ equal (addressMethod addr) "a"
$expect $ equal (addressParameters addr) (Data.Map.fromList [])
, test $ assertions "param" $ do
addr <- requireJust (address "a:b=c")
$expect $ equal (addressMethod addr) "a"
$expect $ equal (addressParameters addr) (Data.Map.fromList [("b", "c")])
, test $ assertions "trailing-semicolon" $ do
addrs <- requireJust (addresses "a:;")
$assert $ equal (length addrs) 1
let [addr1] = addrs
$expect $ equal (addressMethod addr1) "a"
$expect $ equal (addressParameters addr1) (Data.Map.fromList [])
, test $ assertions "two-schemes" $ do
addrs <- requireJust (addresses "a:;b:")
$assert $ equal (length addrs) 2
let [addr1, addr2] = addrs
$expect $ equal (addressMethod addr1) "a"
$expect $ equal (addressParameters addr1) (Data.Map.fromList [])
$expect $ equal (addressMethod addr2) "b"
$expect $ equal (addressParameters addr2) (Data.Map.fromList [])
, test $ assertions "trailing-comma" $ do
addr <- requireJust (address "a:b=c,")
$expect $ equal (addressMethod addr) "a"
$expect $ equal (addressParameters addr) (Data.Map.fromList [("b", "c")])
, test $ assertions "encoded" $ do
addr <- requireJust (address "a:b=%678")
$expect $ equal (addressMethod addr) "a"
$expect $ equal (addressParameters addr) (Data.Map.fromList [("b", "g8")])
]
, suite "invalid"
[ test $ assertions "empty" $ do
$expect $ nothing (address "")
, test $ assertions "no-colon" $ do
$expect $ nothing (address "a")
, test $ assertions "no-equals" $ do
$expect $ nothing (address "a:b")
, test $ assertions "no-param" $ do
$expect $ nothing (address "a:,")
, test $ assertions "no-param-value" $ do
$expect $ nothing (address "a:b=")
]
, suite "passthrough"
[ test $ assertions "plain" $ do
$assert $ equal (Just "a:b=c") (addressText `fmap` address "a:b=c")
, test $ assertions "encoded" $ do
$assert $ equal (Just "a:b=Z%5B") (addressText `fmap` address "a:b=%5a%5b")
, test $ assertions "optionally-encoded" $ do
$assert $ equal (Just "a:b=-_/\\*.") (addressText `fmap` address "a:b=-_/\\*.")
, test $ assertions "multiple-params" $ do
$assert $ equal (Just "a:b=c,d=e") (addressText `fmap` address "a:b=c,d=e")
]
, suite "instances"
[ test $ assertions "eq" $ do
$assert $ equal (address "a:b=c") (address "a:b=c")
, test $ assertions "show" $ do
$assert $ equal "(Address \"a:b=c\")" (showsPrec 11 (fromJust (address "a:b=c")) "")
]
, suite "well-known"
[ test $ assertions "system" $ do
liftIO $ System.Posix.Env.setEnv "DBUS_SYSTEM_BUS_ADDRESS" "a:b=c;d:" True
addrs <- liftIO getSystem
$assert $ equal addrs (Just ["a:b=c", "d:"])
, test $ assertions "default-system" $ do
liftIO $ System.Posix.Env.unsetEnv "DBUS_SYSTEM_BUS_ADDRESS"
addrs <- liftIO getSystem
$assert $ equal addrs (Just ["unix:path=/var/run/dbus/system_bus_socket"])
, test $ assertions "session" $ do
liftIO $ System.Posix.Env.setEnv "DBUS_SESSION_BUS_ADDRESS" "a:b=c;d:" True
addrs <- liftIO getSession
$assert $ equal addrs (Just ["a:b=c", "d:"])
, test $ assertions "starter" $ do
liftIO $ System.Posix.Env.setEnv "DBUS_STARTER_BUS_ADDRESS" "a:b=c;d:" True
addrs <- liftIO getStarter
$assert $ equal addrs (Just ["a:b=c", "d:"])
]
, suite "properties"
[ property "address-parsing" (forAll genAddressText (isJust . address))
]
]
suite_Signature :: Suite
suite_Signature = suite "signature"
[ suite "valid"
[ suite "atom"
[ test $ assertions "bool" $ do
sig <- requireJust (signature "b")
$assert $ equal (signatureTypes sig) [TypeBoolean]
, test $ assertions "word8" $ do
sig <- requireJust (signature "y")
$assert $ equal (signatureTypes sig) [TypeWord8]
, test $ assertions "word16" $ do
sig <- requireJust (signature "q")
$assert $ equal (signatureTypes sig) [TypeWord16]
, test $ assertions "word32" $ do
sig <- requireJust (signature "u")
$assert $ equal (signatureTypes sig) [TypeWord32]
, test $ assertions "word64" $ do
sig <- requireJust (signature "t")
$assert $ equal (signatureTypes sig) [TypeWord64]
, test $ assertions "int16" $ do
sig <- requireJust (signature "n")
$assert $ equal (signatureTypes sig) [TypeInt16]
, test $ assertions "int32" $ do
sig <- requireJust (signature "i")
$assert $ equal (signatureTypes sig) [TypeInt32]
, test $ assertions "int64" $ do
sig <- requireJust (signature "x")
$assert $ equal (signatureTypes sig) [TypeInt64]
, test $ assertions "double" $ do
sig <- requireJust (signature "d")
$assert $ equal (signatureTypes sig) [TypeDouble]
, test $ assertions "string" $ do
sig <- requireJust (signature "s")
$assert $ equal (signatureTypes sig) [TypeString]
, test $ assertions "object-path" $ do
sig <- requireJust (signature "o")
$assert $ equal (signatureTypes sig) [TypeObjectPath]
, test $ assertions "signature" $ do
sig <- requireJust (signature "g")
$assert $ equal (signatureTypes sig) [TypeSignature]
]
, suite "container"
[ test $ assertions "variant" $ do
sig <- requireJust (signature "v")
$assert $ equal (signatureTypes sig) [TypeVariant]
, test $ assertions "array" $ do
sig <- requireJust (signature "ay")
$assert $ equal (signatureTypes sig) [TypeArray TypeWord8]
, test $ assertions "struct" $ do
sig <- requireJust (signature "(yy)")
$assert $ equal (signatureTypes sig) [TypeStructure [TypeWord8, TypeWord8]]
, test $ assertions "dictionary" $ do
sig <- requireJust (signature "a{yy}")
$assert $ equal (signatureTypes sig) [TypeDictionary TypeWord8 TypeWord8]
]
, test $ assertions "empty" $ do
sig <- requireJust (signature "")
$assert $ equal (signatureTypes sig) []
]
, suite "invalid"
[ test $ assertions "struct-code" ($assert $ nothing (signature "r"))
, test $ assertions "struct-empty" ($assert $ nothing (signature "()"))
, test $ assertions "dict-code" ($assert $ nothing (signature "e"))
, test $ assertions "dict-container-key" ($assert $ nothing (signature "a{vy}"))
, test $ assertions "unix-fd" ($assert $ nothing (signature "h"))
]
, suite "length"
[ test $ assertions "length-254" $ do
sig <- requireJust (signature (T.replicate 254 "y"))
$assert $ equal (signatureTypes sig) (replicate 254 TypeWord8)
, test $ assertions "length-255" $ do
sig <- requireJust (signature (T.replicate 255 "y"))
$assert $ equal (signatureTypes sig) (replicate 255 TypeWord8)
, test $ assertions "length-256" ($assert $ nothing (signature (T.replicate 256 "y")))
]
, suite "instances"
[ test $ assertions "show" ($assert $ equal "(Signature \"y\")" (showsPrec 11 (fromJust (signature "y")) ""))
]
, suite "properties"
[ property "signature-parsing" (forAll genSignatureText (isJust . signature))
, property "check-signature" $ do
let prop types = checkSignature types == signature (T.pack (concatMap typeCode types))
forAll (listOf1 arbitrary) prop
]
]
suite_Types :: Suite
suite_Types = suite "types"
[ suite "instances"
[ test $ assertions "eq" ($assert $ equal TypeWord8 TypeWord8)
, suite "show"
[ test $ assertions "Boolean" ($assert $ equal "Bool" (show TypeBoolean))
, test $ assertions "Word8" ($assert $ equal "Word8" (show TypeWord8))
, test $ assertions "Word16" ($assert $ equal "Word16" (show TypeWord16))
, test $ assertions "Word32" ($assert $ equal "Word32" (show TypeWord32))
, test $ assertions "Word64" ($assert $ equal "Word64" (show TypeWord64))
, test $ assertions "Int16" ($assert $ equal "Int16" (show TypeInt16))
, test $ assertions "Int32" ($assert $ equal "Int32" (show TypeInt32))
, test $ assertions "Int64" ($assert $ equal "Int64" (show TypeInt64))
, test $ assertions "Double" ($assert $ equal "Double" (show TypeDouble))
, test $ assertions "String" ($assert $ equal "String" (show TypeString))
, test $ assertions "Signature" ($assert $ equal "Signature" (show TypeSignature))
, test $ assertions "ObjectPath" ($assert $ equal "ObjectPath" (show TypeObjectPath))
, test $ assertions "Variant" ($assert $ equal "Variant" (show TypeVariant))
, test $ assertions "Array" ($assert $ equal "[Word8]" (show (TypeArray TypeWord8)))
, test $ assertions "Dictionary" ($assert $ equal "Map Word8 (Map Word8 Word8)" (show (TypeDictionary TypeWord8 (TypeDictionary TypeWord8 TypeWord8))))
, test $ assertions "Structure" ($assert $ equal "(Word8, Word16)" (show (TypeStructure [TypeWord8, TypeWord16])))
]
]
]
suite_Variant :: Suite
suite_Variant = suite "variant"
[ suite "instances-of-IsAtom"
[ test $ assertions "bool" (assertAtom TypeBoolean True)
, test $ assertions "word8" (assertAtom TypeWord8 (0 :: Word8))
, test $ assertions "word16" (assertAtom TypeWord16 (0 :: Word16))
, test $ assertions "word32" (assertAtom TypeWord32 (0 :: Word32))
, test $ assertions "word64" (assertAtom TypeWord64 (0 :: Word64))
, test $ assertions "int16" (assertAtom TypeInt16 (0 :: Int16))
, test $ assertions "int32" (assertAtom TypeInt32 (0 :: Int32))
, test $ assertions "int64" (assertAtom TypeInt64 (0 :: Int64))
, test $ assertions "double" (assertAtom TypeDouble (0 :: Double))
, test $ assertions "text" (assertAtom TypeString (Data.Text.pack ""))
, test $ assertions "lazy-text" (assertAtom TypeString (Data.Text.Lazy.pack ""))
, test $ assertions "string" (assertAtom TypeString ("" :: String))
, test $ assertions "object-path" (assertAtom TypeObjectPath (objectPath_ "/"))
, test $ assertions "signature" (assertAtom TypeSignature (signature_ ""))
]
, suite "instances-of-IsValue"
[ test $ assertions "variant" (assertValue TypeVariant (toVariant True))
, test $ assertions "list" (assertValue (TypeArray TypeBoolean) [True])
, test $ assertions "vector" (assertValue (TypeArray TypeBoolean) (Data.Vector.fromList [True]))
, test $ assertions "bytestring-strict" (assertValue (TypeArray TypeWord8) Data.ByteString.empty)
, test $ assertions "bytestring-lazy" (assertValue (TypeArray TypeWord8) Data.ByteString.Lazy.empty)
, test $ assertions "map" (assertValue (TypeDictionary TypeBoolean TypeBoolean) (Data.Map.fromList [(True, True)]))
, test $ assertions "tuple-2" (assertValue (TypeStructure (replicate 2 TypeBoolean)) (True, True))
, test $ assertions "tuple-3" (assertValue (TypeStructure (replicate 3 TypeBoolean)) (True, True, True))
, test $ assertions "tuple-4" (assertValue (TypeStructure (replicate 4 TypeBoolean)) (True, True, True, True))
, test $ assertions "tuple-5" (assertValue (TypeStructure (replicate 5 TypeBoolean)) (True, True, True, True, True))
, test $ assertions "tuple-6" (assertValue (TypeStructure (replicate 6 TypeBoolean)) (True, True, True, True, True, True))
, test $ assertions "tuple-7" (assertValue (TypeStructure (replicate 7 TypeBoolean)) (True, True, True, True, True, True, True))
, test $ assertions "tuple-8" (assertValue (TypeStructure (replicate 8 TypeBoolean)) (True, True, True, True, True, True, True, True))
, test $ assertions "tuple-9" (assertValue (TypeStructure (replicate 9 TypeBoolean)) (True, True, True, True, True, True, True, True, True))
, test $ assertions "tuple-10" (assertValue (TypeStructure (replicate 10 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True))
, test $ assertions "tuple-11" (assertValue (TypeStructure (replicate 11 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True))
, test $ assertions "tuple-12" (assertValue (TypeStructure (replicate 12 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True))
, test $ assertions "tuple-13" (assertValue (TypeStructure (replicate 13 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True))
, test $ assertions "tuple-14" (assertValue (TypeStructure (replicate 14 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True, True))
, test $ assertions "tuple-15" (assertValue (TypeStructure (replicate 15 TypeBoolean)) (True, True, True, True, True, True, True, True, True, True, True, True, True, True, True))
]
, suite "show-variant"
[ test $ assertions "bool" ($assert $ equal "Variant True" (show (toVariant True)))
, test $ assertions "word8" ($assert $ equal "Variant 0" (show (toVariant (0 :: Word8))))
, test $ assertions "word16" ($assert $ equal "Variant 0" (show (toVariant (0 :: Word16))))
, test $ assertions "word32" ($assert $ equal "Variant 0" (show (toVariant (0 :: Word32))))
, test $ assertions "word64" ($assert $ equal "Variant 0" (show (toVariant (0 :: Word64))))
, test $ assertions "int16" ($assert $ equal "Variant 0" (show (toVariant (0 :: Int16))))
, test $ assertions "int32" ($assert $ equal "Variant 0" (show (toVariant (0 :: Int32))))
, test $ assertions "int64" ($assert $ equal "Variant 0" (show (toVariant (0 :: Int64))))
, test $ assertions "double" ($assert $ equal "Variant 0.1" (show (toVariant (0.1 :: Double))))
, test $ assertions "string" ($assert $ equal "Variant \"\"" (show (toVariant (T.pack ""))))
, test $ assertions "object-path" ($assert $ equal "Variant (ObjectPath \"/\")" (show (toVariant (objectPath_ "/"))))
, test $ assertions "signature" ($assert $ equal "Variant (Signature \"\")" (show (toVariant (signature_ ""))))
, test $ assertions "variant" ($assert $ equal "Variant (Variant True)" (show (toVariant (toVariant True))))
, test $ assertions "array" ($assert $ equal "Variant [True, False]" (show (toVariant [True, False])))
, suite "array"
[ test $ assertions "bytestring-strict" ($assert $ equal "Variant b\"\"" (show (toVariant Data.ByteString.empty)))
, test $ assertions "bytestring-lazy" ($assert $ equal "Variant b\"\"" (show (toVariant Data.ByteString.Lazy.empty)))
, test $ assertions "array-of-word8" ($assert $ equal "Variant b\"\"" (show (toVariant ([] :: [Word8]))))
]
, test $ assertions "dictionary" ($assert $ equal "(Variant {False: True, True: False})" (showsPrec 11 (toVariant (Data.Map.fromList [(True, False), (False, True)])) ""))
, test $ assertions "structure" ($assert $ equal "(Variant (True, False))" (showsPrec 11 (toVariant (True, False)) ""))
]
, test $ assertions "compare-byte-storage" $ do
$assert $ equal (toValue (Data.Vector.fromList [0 :: Word8]))
(toValue (Data.Vector.fromList [0 :: Word8]))
$assert $ equal (toValue (Data.Vector.fromList [0 :: Word8]))
(toValue (Data.ByteString.pack [0]))
$assert $ equal (toValue (Data.Vector.fromList [0 :: Word8]))
(toValue (Data.ByteString.Lazy.pack [0]))
$assert $ equal (toValue (Data.ByteString.pack [0]))
(toValue (Data.Vector.fromList [0 :: Word8]))
$assert $ equal (toValue (Data.ByteString.pack [0]))
(toValue (Data.ByteString.pack [0]))
$assert $ equal (toValue (Data.ByteString.pack [0]))
(toValue (Data.ByteString.Lazy.pack [0]))
$assert $ equal (toValue (Data.ByteString.Lazy.pack [0]))
(toValue (Data.Vector.fromList [0 :: Word8]))
$assert $ equal (toValue (Data.ByteString.Lazy.pack [0]))
(toValue (Data.ByteString.pack [0]))
$assert $ equal (toValue (Data.ByteString.Lazy.pack [0]))
(toValue (Data.ByteString.Lazy.pack [0]))
]
suite_ContainerBoxes :: Suite
suite_ContainerBoxes = suite "container-boxes"
[ suite "structure"
[ test $ assertions "instance-of-Eq" ($assert $ equal (Structure []) (Structure []))
, test $ assertions "instance-of-Show" ($assert $ equal "(True, False)" (show (Structure [toValue True, toValue False])))
, test $ assertions "instance-of-IsVariant" (assertVariant (TypeStructure [TypeBoolean]) (Structure [toValue True]))
]
, suite "array"
[ test $ assertions "instance-of-Eq" $ do
$assert $ equal (Array TypeBoolean (Data.Vector.fromList [toValue True]))
(Array TypeBoolean (Data.Vector.fromList [toValue True]))
$assert $ equal (Array TypeWord8 (Data.Vector.fromList [toValue (0 :: Word8)]))
(ArrayBytes (Data.ByteString.pack [0]))
, test $ assertions "instance-of-Show" $ do
$assert $ equal "[True, False]" (show (Array TypeBoolean (Data.Vector.fromList [toValue True, toValue False])))
$assert $ equal "b\"\"" (show (Array TypeWord8 Data.Vector.empty))
$assert $ equal "b\"\"" (show (ArrayBytes Data.ByteString.empty))
, test $ assertions "instance-of-IsVariant" $ do
assertVariant (TypeArray TypeWord8) (Array TypeWord8 Data.Vector.empty)
assertVariant (TypeArray TypeWord8) (ArrayBytes Data.ByteString.empty)
]
, suite "dictionary"
[ test $ assertions "instance-of-Eq" ($assert $ equal (Dictionary TypeWord8 TypeWord8 Data.Map.empty)
(Dictionary TypeWord8 TypeWord8 Data.Map.empty))
, test $ assertions "instance-of-Show" ($assert $ equal "{}" (show (Dictionary TypeWord8 TypeWord8 Data.Map.empty)))
, test $ assertions "instance-of-IsVariant" (assertVariant (TypeDictionary TypeWord8 TypeWord8) (Dictionary TypeWord8 TypeWord8 Data.Map.empty))
]
]
suite_ObjectPath :: Suite
suite_ObjectPath = suite "object-path"
[ suite "valid"
[ test $ assertions "root" ($assert $ just (objectPath "/"))
, test $ assertions "plain-1" ($assert $ just (objectPath "/foo"))
, test $ assertions "plain-2" ($assert $ just (objectPath "/foo/bar"))
, test $ assertions "start-with-digit" ($assert $ just (objectPath "/foo/0"))
, test $ assertions "all-characters" ($assert $ just (objectPath "/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
]
, suite "invalid"
[ test $ assertions "empty" ($assert $ nothing (objectPath ""))
, test $ assertions "bad-char" ($assert $ nothing (objectPath "/f!oo"))
, test $ assertions "end-with-slash" ($assert $ nothing (objectPath "/foo/"))
, test $ assertions "empty-element" ($assert $ nothing (objectPath "/foo//bar"))
, test $ assertions "trailing-chars" ($assert $ nothing (objectPath "/foo!"))
]
]
suite_InterfaceName :: Suite
suite_InterfaceName = suite "interface-name"
[ test $ assertions "instance-of-IsVariant" (assertVariant TypeString (interfaceName_ "foo.bar"))
, suite "valid"
[ test $ assertions "plain" ($assert $ just (interfaceName "foo.bar"))
, test $ assertions "has-digit" ($assert $ just (interfaceName "foo.bar0"))
, test $ assertions "all-characters" ($assert $ just (interfaceName "a.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
]
, suite "invalid"
[ test $ assertions "empty" ($assert $ nothing (interfaceName ""))
, test $ assertions "one-element" ($assert $ nothing (interfaceName "foo"))
, test $ assertions "start-with-digit" ($assert $ nothing (interfaceName "foo.0bar"))
, test $ assertions "trailing-chars" ($assert $ nothing (interfaceName "foo.bar!"))
]
, suite "length"
[ test $ assertions "length-254" ($assert $ just (interfaceName ("f." `T.append` T.replicate 252 "y")))
, test $ assertions "length-255" ($assert $ just (interfaceName ("f." `T.append` T.replicate 253 "y")))
, test $ assertions "length-256" ($assert $ nothing (interfaceName ("f." `T.append` T.replicate 254 "y")))
]
]
suite_MemberName :: Suite
suite_MemberName = suite "member-name"
[ test $ assertions "instance-of-IsVariant" (assertVariant TypeString (memberName_ "foo"))
, suite "valid"
[ test $ assertions "plain" ($assert $ just (memberName "foo"))
, test $ assertions "has-digit" ($assert $ just (memberName "foo0"))
, test $ assertions "all-characters" ($assert $ just (memberName "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
]
, suite "invalid"
[ test $ assertions "empty" ($assert $ nothing (memberName ""))
, test $ assertions "start-with-digit" ($assert $ nothing (memberName "0foo"))
, test $ assertions "trailing-chars" ($assert $ nothing (memberName "foo!"))
]
, suite "length"
[ test $ assertions "length-254" ($assert $ just (memberName (T.replicate 254 "y")))
, test $ assertions "length-255" ($assert $ just (memberName (T.replicate 255 "y")))
, test $ assertions "length-256" ($assert $ nothing (memberName (T.replicate 256 "y")))
]
]
suite_ErrorName :: Suite
suite_ErrorName = suite "error-name"
[ test $ assertions "instance-of-IsVariant" (assertVariant TypeString (errorName_ "foo.bar"))
, suite "valid"
[ test $ assertions "plain" ($assert $ just (errorName "foo.bar"))
, test $ assertions "has-digit" ($assert $ just (errorName "foo.bar0"))
, test $ assertions "all-characters" ($assert $ just (errorName "a.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
]
, suite "invalid"
[ test $ assertions "empty" ($assert $ nothing (errorName ""))
, test $ assertions "one-element" ($assert $ nothing (errorName "foo"))
, test $ assertions "start-with-digit" ($assert $ nothing (errorName "foo.0bar"))
, test $ assertions "trailing-chars" ($assert $ nothing (errorName "foo.bar!"))
]
, suite "length"
[ test $ assertions "length-254" ($assert $ just (errorName ("f." `T.append` T.replicate 252 "y")))
, test $ assertions "length-255" ($assert $ just (errorName ("f." `T.append` T.replicate 253 "y")))
, test $ assertions "length-256" ($assert $ nothing (errorName ("f." `T.append` T.replicate 254 "y")))
]
]
suite_BusName :: Suite
suite_BusName = suite "bus-name"
[ test $ assertions "instance-of-IsVariant" (assertVariant TypeString (busName_ "foo.bar"))
, suite "valid"
[ suite "unique"
[ test $ assertions "plain" ($assert $ just (busName ":foo.bar"))
, test $ assertions "start-with-digit" ($assert $ just (busName ":foo.0bar"))
, test $ assertions "all-characters" ($assert $ just (busName ":a.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
]
, suite "well-known"
[ test $ assertions "plain" ($assert $ just (busName "foo.bar"))
, test $ assertions "has-digit" ($assert $ just (busName "foo.bar0"))
, test $ assertions "all-characters" ($assert $ just (busName "a.abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
]
]
, suite "invalid"
[ test $ assertions "empty" ($assert $ nothing (busName ""))
, test $ assertions "well-known-start-with-digit" ($assert $ nothing (busName "foo.0bar"))
, test $ assertions "well-known-one-element" ($assert $ nothing (busName "foo"))
, test $ assertions "unique-one-element" ($assert $ nothing (busName ":foo"))
, test $ assertions "trailing-chars" ($assert $ nothing (busName "foo.bar!"))
]
, suite "length"
[ test $ assertions "length-254" ($assert $ just (busName (":0." `T.append` T.replicate 251 "y")))
, test $ assertions "length-255" ($assert $ just (busName (":0." `T.append` T.replicate 252 "y")))
, test $ assertions "length-256" ($assert $ nothing (busName (":0." `T.append` T.replicate 253 "y")))
]
]
suite_Wire :: Suite
suite_Wire = suite "wire"
[ property "value-passthrough" $ \v e ->
let Right bytes = marshal e v in
let Right unmarshaled = unmarshal e (valueType v) bytes in
unmarshaled == v
, suite "message-passthrough"
[ property "method-call" $ forAll (arbitrary :: Gen MethodCall) $ \msg e s ->
let Right bytes = marshalMessage e s msg in
let Right received = unmarshalMessage bytes in
ReceivedMethodCall s Nothing msg == received
, property "method-return" $ forAll (arbitrary :: Gen MethodReturn) $ \msg e s ->
let Right bytes = marshalMessage e s msg in
let Right received = unmarshalMessage bytes in
ReceivedMethodReturn s Nothing msg == received
, property "error" $ forAll (arbitrary :: Gen Error) $ \msg e s ->
let Right bytes = marshalMessage e s msg in
let Right received = unmarshalMessage bytes in
ReceivedError s Nothing msg == received
, property "signal" $ forAll (arbitrary :: Gen Signal) $ \msg e s ->
let Right bytes = marshalMessage e s msg in
let Right received = unmarshalMessage bytes in
ReceivedSignal s Nothing msg == received
]
]
suite_Introspection :: Suite
suite_Introspection = suite "introspection"
[ property "xml-passthrough" $ \obj ->
let (DBus.Introspection.Object path _ _) = obj in
let Just xml = DBus.Introspection.toXML obj in
DBus.Introspection.fromXML path xml == Just obj
]
marshal :: DBus.Wire.Endianness -> Value -> Either String ByteString
marshal e v = case DBus.Wire.Internal.unWire (DBus.Wire.Internal.marshal v) e (DBus.Wire.Internal.MarshalState Data.Binary.Builder.empty 0) of
DBus.Wire.Internal.WireRR _ (DBus.Wire.Internal.MarshalState builder _) -> Right (Data.ByteString.concat (Data.ByteString.Lazy.toChunks (Data.Binary.Builder.toLazyByteString builder)))
DBus.Wire.Internal.WireRL err -> Left err
unmarshal :: DBus.Wire.Endianness -> Type -> ByteString -> Either String Value
unmarshal e t bytes = case DBus.Wire.Internal.unWire (DBus.Wire.Internal.unmarshal t) e (DBus.Wire.Internal.UnmarshalState bytes 0) of
DBus.Wire.Internal.WireRR v _ -> Right v
DBus.Wire.Internal.WireRL err -> Left err
genAddressText :: Gen Text
genAddressText = gen where
methodChars = filter (`notElem` ":;") ['!'..'~']
keyChars = filter (`notElem` "=;,") ['!'..'~']
optionallyEncoded = map (:[]) (concat
[ ['0'..'9']
, ['a'..'z']
, ['A'..'Z']
, "-_/\\*."
])
param = do
key <- listOf1 (elements keyChars)
value <- listOf1 (oneof
[ elements optionallyEncoded
, do
c1 <- genHex
c2 <- genHex
return ['%', c1, c2]
])
return (key ++ "=" ++ concat value)
gen = do
method <- listOf (elements methodChars)
params <- listOf param
return (T.pack (method ++ ":" ++ (intercalate "," params)))
genHex :: Gen Char
genHex = elements (['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F'])
genSignatureText :: Gen Text
genSignatureText = gen where
anyType = oneof [atom, container]
atom = elements ["b", "y", "q", "u", "t", "n", "i", "x", "d", "s", "o", "g"]
container = oneof
[ return "v"
, do
t <- anyType
return ('a' : t)
, do
kt <- atom
vt <- anyType
return (concat ["a{", kt, vt, "}"])
, do
ts <- listOf1 (halfSized anyType)
return (concat (["("] ++ ts ++ [")"]))
]
gen = do
chars <- fmap concat (listOf anyType)
if length chars > 255
then halfSized gen
else return (T.pack chars)
halfSized :: Gen a -> Gen a
halfSized gen = sized (\n -> if n > 0
then resize (div n 2) gen
else gen)
requireJust :: Maybe a -> Assertions a
requireJust (Just a) = return a
requireJust Nothing = $fail "requireJust: got Nothing"
withEnv :: String -> Maybe String -> IO a -> IO a
withEnv name value io = do
let set val = case val of
Just x -> System.Posix.Env.setEnv name x True
Nothing -> System.Posix.Env.unsetEnv name
old <- System.Posix.Env.getEnv name
Control.Exception.bracket_ (set value) (set old) io
instance IsString Address where
fromString s = case address (T.pack s) of
Just addr -> addr
Nothing -> error ("Invalid address: " ++ show s)
instance Arbitrary Type where
arbitrary = oneof [atom, container] where
atom = elements
[ TypeBoolean
, TypeWord8
, TypeWord16
, TypeWord32
, TypeWord64
, TypeInt16
, TypeInt32
, TypeInt64
, TypeDouble
, TypeString
, TypeObjectPath
, TypeSignature
]
container = oneof
[ return TypeVariant
, liftM TypeArray arbitrary
, liftM2 TypeDictionary atom arbitrary
, liftM TypeStructure (listOf1 (halfSized arbitrary))
]
instance Arbitrary Atom where
arbitrary = oneof
[ liftM AtomWord8 arbitrary
, liftM AtomWord16 arbitrary
, liftM AtomWord32 arbitrary
, liftM AtomWord64 arbitrary
, liftM AtomInt16 arbitrary
, liftM AtomInt32 arbitrary
, liftM AtomInt64 arbitrary
, liftM AtomBool arbitrary
, liftM AtomDouble arbitrary
, liftM AtomText arbitrary
, liftM AtomObjectPath arbitrary
, liftM AtomSignature arbitrary
]
instance Arbitrary Value where
arbitrary = oneof
[ liftM ValueAtom arbitrary
, liftM ValueBytes arbitrary
-- TODO: proper arbitrary ValueVector
, elements
[ toValue (Data.Vector.fromList ([] :: [Word8]))
, toValue (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word8]))
, toValue (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word16]))
, toValue (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word32]))
, toValue (Data.Vector.fromList ([0, 1, 2, 3, 4, 5] :: [Word64]))
, toValue (Data.Vector.fromList (["foo", "bar", "baz"] :: [Text]))
]
-- TODO: proper arbitrary ValueMap
, elements
[ toValue (Data.Map.fromList [] :: Map Text Text)
, toValue (Data.Map.fromList [("foo", "bar"), ("baz", "qux")] :: Map Text Text)
]
, liftM ValueStructure (listOf1 (halfSized arbitrary))
, liftM ValueVariant arbitrary
]
instance Arbitrary Variant where
arbitrary = do
val <- arbitrary
case checkSignature [valueType val] of
Just _ -> return (Variant val)
Nothing -> halfSized arbitrary
instance Arbitrary Data.Text.Text where
arbitrary = liftM Data.Text.pack genUnicode
genUnicode :: Gen [Char]
genUnicode = string where
string = sized $ \n -> do
k <- choose (0,n)
sequence [ char | _ <- [1..k] ]
excluding :: [a -> Bool] -> Gen a -> Gen a
excluding bad gen = loop where
loop = do
x <- gen
if or (map ($ x) bad)
then loop
else return x
reserved = [lowSurrogate, highSurrogate, noncharacter]
lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF
highSurrogate c = c >= 0xD800 && c <= 0xDBFF
noncharacter c = masked == 0xFFFE || masked == 0xFFFF where
masked = c .&. 0xFFFF
ascii = choose (0x20, 0x7F)
plane0 = choose (0xF0, 0xFFFF)
plane1 = oneof [ choose (0x10000, 0x10FFF)
, choose (0x11000, 0x11FFF)
, choose (0x12000, 0x12FFF)
, choose (0x13000, 0x13FFF)
, choose (0x1D000, 0x1DFFF)
, choose (0x1F000, 0x1FFFF)
]
plane2 = oneof [ choose (0x20000, 0x20FFF)
, choose (0x21000, 0x21FFF)
, choose (0x22000, 0x22FFF)
, choose (0x23000, 0x23FFF)
, choose (0x24000, 0x24FFF)
, choose (0x25000, 0x25FFF)
, choose (0x26000, 0x26FFF)
, choose (0x27000, 0x27FFF)
, choose (0x28000, 0x28FFF)
, choose (0x29000, 0x29FFF)
, choose (0x2A000, 0x2AFFF)
, choose (0x2B000, 0x2BFFF)
, choose (0x2F000, 0x2FFFF)
]
plane14 = choose (0xE0000, 0xE0FFF)
planes = [ascii, plane0, plane1, plane2, plane14]
char = chr `fmap` excluding reserved (oneof planes)
instance Arbitrary Data.ByteString.ByteString where
arbitrary = liftM Data.ByteString.pack arbitrary
instance Arbitrary Data.ByteString.Lazy.ByteString where
arbitrary = liftM Data.ByteString.Lazy.fromChunks arbitrary
instance Arbitrary ObjectPath where
-- TODO: proper arbitrary generation
arbitrary = elements
[ objectPath_ "/"
, objectPath_ "/foo"
, objectPath_ "/foo/bar"
]
instance Arbitrary InterfaceName where
-- TODO: proper arbitrary generation
arbitrary = elements
[ interfaceName_ "foo.bar"
, interfaceName_ "foo.bar0"
]
instance Arbitrary MemberName where
-- TODO: proper arbitrary generation
arbitrary = elements
[ memberName_ "foo"
, memberName_ "foo0"
]
instance Arbitrary ErrorName where
-- TODO: proper arbitrary generation
arbitrary = elements
[ errorName_ "foo.bar"
, errorName_ "foo.bar0"
]
instance Arbitrary BusName where
-- TODO: proper arbitrary generation
arbitrary = elements
[ busName_ "foo.bar"
, busName_ ":foo.bar"
, busName_ ":foo.bar"
]
instance (Arbitrary a, Ord a) => Arbitrary (Data.Set.Set a) where
arbitrary = liftM Data.Set.fromList arbitrary
instance Arbitrary Signature where
arbitrary = liftM signature_ genSignatureText
instance Arbitrary DBus.Wire.Endianness where
arbitrary = elements [DBus.Wire.BigEndian, DBus.Wire.LittleEndian]
instance Arbitrary Flag where
arbitrary = elements [NoReplyExpected, NoAutoStart]
instance Arbitrary Serial where
arbitrary = liftM Serial arbitrary
instance Arbitrary MethodCall where
arbitrary = MethodCall
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> genMessageBody
instance Arbitrary MethodReturn where
arbitrary = MethodReturn
<$> arbitrary
<*> arbitrary
<*> genMessageBody
instance Arbitrary Error where
arbitrary = Error
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> genMessageBody
instance Arbitrary Signal where
arbitrary = Signal
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> genMessageBody
genMessageBody :: Gen [Variant]
genMessageBody = do
vars <- arbitrary
case checkSignature (map variantType vars) of
Just _ -> return vars
Nothing -> halfSized genMessageBody
instance Arbitrary DBus.Introspection.Object where
arbitrary = arbitrary >>= subObject
subObject :: ObjectPath -> Gen DBus.Introspection.Object
subObject parentPath = sized $ \n -> resize (min n 4) $ do
let nonRoot = do
x <- arbitrary
case objectPathText x of
"/" -> nonRoot
x' -> return x'
thisPath <- nonRoot
let path' = case objectPathText parentPath of
"/" -> thisPath
x -> Data.Text.append x thisPath
let path = objectPath_ path'
ifaces <- arbitrary
children <- halfSized (listOf (subObject path))
return (DBus.Introspection.Object path ifaces children)
instance Arbitrary DBus.Introspection.Interface where
arbitrary = DBus.Introspection.Interface
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
instance Arbitrary DBus.Introspection.Method where
arbitrary = DBus.Introspection.Method
<$> arbitrary
<*> arbitrary
<*> arbitrary
instance Arbitrary DBus.Introspection.Signal where
arbitrary = DBus.Introspection.Signal
<$> arbitrary
<*> arbitrary
instance Arbitrary DBus.Introspection.Parameter where
arbitrary = DBus.Introspection.Parameter
<$> arbitrary
<*> singleType
instance Arbitrary DBus.Introspection.Property where
arbitrary = DBus.Introspection.Property
<$> arbitrary
<*> arbitrary
<*> elements
[ []
, [ DBus.Introspection.Read ]
, [ DBus.Introspection.Write ]
, [ DBus.Introspection.Read
, DBus.Introspection.Write ]
]
singleType :: Gen Signature
singleType = do
t <- arbitrary
case checkSignature [t] of
Just s -> return s
Nothing -> halfSized singleType