Browse files

add test cases and benchmarks

  • Loading branch information...
1 parent 387d5f8 commit 2ac67362c5948f06e44e7eddde8bcc41f56b36ba @Philonous Philonous committed Dec 14, 2013
View
12 benchmarks/Bench.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Criterion.Main
+import Network.Xmpp.Types
+
+bench_jidFromTexts = whnf (\(a,b,c) -> jidFromTexts a b c)
+ ( Just "+\227\161[\\3\8260\&4"
+ , "\242|8e3\EOTrf6\DLEp\\\a"
+ , Just ")\211\226")
+
+main = do defaultMain [bench "jidFromTexts 2" bench_jidFromTexts]
View
36 pontarius-xmpp.cabal
@@ -120,18 +120,40 @@ Test-Suite tests
Type: exitcode-stdio-1.0
main-is: Main.hs
Build-Depends: base
- , tasty
+ , Cabal
+ , QuickCheck
+ , async
+ , conduit
+ , containers
+ , derive
, hspec
- , tasty-hspec
+ , hspec-expectations
, pontarius-xmpp
- , Cabal
+ , quickcheck-instances
+ , ranges
, smallcheck
- , tasty-smallcheck
+ , stringprep >= 0.1.5
+ , tasty
+ , tasty-hspec
+ , tasty-quickcheck
, tasty-th
- , hspec-expectations
- , async
- , derive
+ , text
+ , xml-picklers
+ , xml-types
HS-Source-Dirs: tests
+ Other-modules: Tests.Arbitrary
+ , Tests.Arbitrary.Xml
+ , Tests.Arbitrary.Xmpp
+ ghc-options: -Wall -O2 -fno-warn-orphans
+
+benchmark benchmarks
+ type: exitcode-stdio-1.0
+ build-depends: base
+ , criterion
+ , pontarius-xmpp
+ hs-source-dirs: benchmarks
+ main-is: Bench.hs
+ ghc-options: -O2
Source-Repository head
Type: git
View
8 tests/DataForms.hs
@@ -9,7 +9,7 @@ import qualified Text.XML.Stream.Elements as Elements
import qualified Data.XML.Types as XML
import Data.XML.Pickle
-test1 = TL.concat $
+exampleXML1 = TL.concat $
["<x xmlns='jabber:x:data' type='form'>"
,"<title>Bot Configuration</title>"
,"<instructions>Fill out this form to configure your new bot!</instructions>"
@@ -64,7 +64,7 @@ test1 = TL.concat $
,"</field>"
,"</x>"]
-test2 = TL.concat [
+exampleXml2 = TL.concat [
" <x xmlns='jabber:x:data' type='submit'>"
," <field type='hidden' var='FORM_TYPE'>"
," <value>jabber:bot</value>"
@@ -98,7 +98,7 @@ test2 = TL.concat [
," </x>"]
-test3 = TL.concat [
+exampleXml3 = TL.concat [
" <x xmlns='jabber:x:data' type='result'>"
, " <field type='hidden' var='FORM_TYPE'>"
, " <value>jabber:bot</value>"
@@ -125,4 +125,4 @@ test3 = TL.concat [
, " </field>"
, " </x>"]
-parseForm = unpickleTree (xpRoot xpForm) . XML.NodeElement . Elements.parseElement
+parseForm = unpickleTree (xpRoot xpForm) . XML.NodeElement . Elements.parseElement
View
11 tests/Main.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import Test.Tasty
+
+import Tests.Parsers
+import Tests.Picklers
+
+main :: IO ()
+main = defaultMain $ testGroup "root" [ parserTests
+ , picklerTests
+ ]
View
6 tests/Tests/Arbitrary.hs
@@ -0,0 +1,6 @@
+module Tests.Arbitrary where
+
+import Tests.Arbitrary.Xml ()
+import Tests.Arbitrary.Xmpp ()
+
+-- $derive makeArbitrary IQRequestType
View
17 tests/Tests/Arbitrary/Common.hs
@@ -0,0 +1,17 @@
+module Tests.Arbitrary.Common where
+
+import Data.Char
+import qualified Data.Text as Text
+import Test.QuickCheck
+import Test.QuickCheck.Instances ()
+
+shrinkText1 :: Text.Text -> [Text.Text]
+shrinkText1 txt = filter (not . Text.null) $ shrink txt
+
+shrinkTextMaybe :: Maybe Text.Text -> [Maybe Text.Text]
+shrinkTextMaybe mbtxt = filter (\mb -> mb /= Just (Text.empty)) $ shrink mbtxt
+
+genText1 :: Gen Text.Text
+genText1 = Text.pack `fmap` string1
+ where
+ string1 = listOf1 arbitrary `suchThat` (not . all isSpace)
View
85 tests/Tests/Arbitrary/Xml.hs
@@ -0,0 +1,85 @@
+module Tests.Arbitrary.Xml where
+
+import Control.Applicative ((<$>), (<*>))
+import Test.QuickCheck
+import Test.QuickCheck.Instances()
+-- import Data.DeriveTH
+import qualified Data.Text as Text
+import Data.XML.Types
+import Tests.Arbitrary.Common
+import Text.CharRanges
+
+
+selectFromRange :: Range -> Gen Char
+selectFromRange (Single a) = return a
+selectFromRange (Range a b) = choose (a, b)
+
+nameStartChar :: [Range]
+nameStartChar =
+ [ -- Single ':'
+ Single '_'
+ , Range 'A' 'Z'
+ , Range 'a' 'z'
+ , Range '\xC0' '\xD6'
+ , Range '\xD8' '\xF6'
+ , Range '\xF8' '\x2FF'
+ , Range '\x370' '\x37D'
+ , Range '\x37F' '\x1FFF'
+ , Range '\x200C' '\x200D'
+ , Range '\x2070' '\x218F'
+ , Range '\x2C00' '\x2FEF'
+ , Range '\x3001' '\xD7FF'
+ , Range '\xF900' '\xFDCF'
+ , Range '\xFDF0' '\xFFFD'
+ , Range '\x10000' '\xEFFFF'
+ ]
+
+nameChar :: [Range]
+nameChar =
+ Single '-'
+ : Single '.'
+ : Single '\xB7'
+ : Range '0' '9'
+ : Range '\x0300' '\x036F'
+ : Range '\x203F' '\x2040'
+ : nameStartChar
+
+
+genNCName :: Gen Text.Text
+genNCName = do
+ sc <- elements nameStartChar >>= selectFromRange
+ ncs <- listOf $ elements nameChar >>= selectFromRange
+ return . Text.pack $ sc:ncs
+
+-- | Cap the size of child elements.
+slow :: Gen a -> Gen a
+slow g = sized $ \n -> resize (min 5 (n `div` 4)) g
+
+instance Arbitrary Name where
+ arbitrary = Name <$> genNCName <*> genMaybe genNCName <*> genMaybe genNCName
+ where
+ genMaybe g = oneof [return Nothing, Just <$> g]
+ shrink (Name a b c) = [ Name a' b c | a' <- shrinkText1 a]
+ ++[ Name a b' c | b' <- shrinkTextMaybe b]
+ ++[ Name a b c' | c' <- shrinkTextMaybe c]
+
+instance Arbitrary Content where
+ arbitrary = ContentText <$> arbitrary
+ shrink (ContentText txt) = ContentText <$> shrinkText1 txt
+ shrink _ = []
+
+
+instance Arbitrary Node where
+ arbitrary = oneof [ NodeElement <$> arbitrary
+ , NodeContent <$> arbitrary
+ ]
+ shrink (NodeElement e) = NodeElement <$> shrink e
+ shrink (NodeContent c) = NodeContent <$> shrink c
+ shrink _ = []
+
+instance Arbitrary Element where
+ arbitrary = Element <$> arbitrary <*> slow arbitrary <*> slow arbitrary
+ shrink (Element a b c) =
+ [ Element a' b c | a' <- shrink a]
+ ++[ Element a b' c | b' <- shrink b]
+ ++[ Element a b c' | c' <- shrink c]
View
93 tests/Tests/Arbitrary/Xmpp.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Tests.Arbitrary.Xmpp where
+
+import Control.Applicative ((<$>), (<*>))
+import Data.Maybe
+import qualified Data.Text as Text
+import Network.Xmpp.Types
+import Test.QuickCheck
+import Test.QuickCheck.Instances()
+import qualified Text.CharRanges as Ranges
+import qualified Text.StringPrep as SP
+import qualified Text.StringPrep.Profiles as SP
+
+import Tests.Arbitrary.Common
+import Tests.Arbitrary.Xml ()
+
+import Data.Derive.Arbitrary
+import Data.DeriveTH
+
+
+instance Arbitrary Jid where
+ arbitrary = do
+ Just jid <- tryJid `suchThat` isJust
+ return jid
+ where
+ tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile)
+ <*> genString (SP.namePrepProfile False)
+ <*> maybeGen (genString resourceprepProfile)
+ maybeGen g = oneof [ return Nothing
+ , Just <$> g
+ ]
+ genString profile = Text.pack . take 1024 <$> listOf1 genChar
+ where
+ genChar = arbitrary `suchThat` (not . isProhibited)
+ prohibited = Ranges.toSet $ concat (SP.prohibited profile)
+ isProhibited x = Ranges.member x prohibited
+ || x `elem` "@/"
+
+ shrink (Jid lp dp rp) = [ Jid lp' dp rp | lp' <- shrinkTextMaybe lp]
+ ++ [ Jid lp dp' rp | dp' <- shrinkText1 dp]
+ ++ [ Jid lp dp rp' | rp' <- shrinkTextMaybe rp]
+
+
+string :: SP.StringPrepProfile -> Gen [Char]
+string profile = take 1024 <$> listOf1 genChar
+ where
+ genChar = arbitrary `suchThat` (not . isProhibited)
+ prohibited = Ranges.toSet $ concat (SP.prohibited profile)
+ isProhibited x = Ranges.member x prohibited
+ || x `elem` "@/"
+
+instance Arbitrary LangTag where
+ arbitrary = LangTag <$> genTag <*> listOf genTag
+ where genTag = fmap Text.pack . listOf1 . elements $ ['a'..'z'] ++ ['A'..'Z']
+ shrink (LangTag lt lts) = [LangTag lt' lts | lt' <- shrinkText1 lt] ++
+ [LangTag lt lts' | lts' <- filter (not . Text.null)
+ <$> shrink lts]
+
+
+instance Arbitrary StanzaError where
+ arbitrary = StanzaError <$> arbitrary
+ <*> arbitrary
+ <*> oneof [ return Nothing
+ , Just <$> ((,) <$> arbitrary <*> genText1)
+ ]
+ <*> arbitrary
+
+-- Auto-derive trivial instances
+concat <$> mapM (derive makeArbitrary) [ ''StanzaErrorType
+ , ''StanzaErrorCondition
+ , ''IQRequestType
+ , ''IQRequest
+ , ''IQResult
+ , ''IQError
+ , ''MessageType
+ , ''Message
+ , ''MessageError
+ , ''PresenceType
+ , ''Presence
+ , ''PresenceError
+ , ''Stanza
+
+ , ''SaslError
+ , ''SaslFailure
+ , ''StreamErrorCondition
+ , ''StreamErrorInfo
+ -- , ''HandshakeFailed
+ -- , ''XmppTlsError
+-- , ''AuthFailure
+ , ''Version
+ , ''ConnectionState
+ , ''TlsBehaviour
+ ]
View
57 tests/Tests/Parsers.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Tests.Parsers where
+
+import Control.Applicative ((<$>))
+import Network.Xmpp.Types
+import Test.Hspec
+import Test.Tasty.QuickCheck
+import Test.Tasty
+import Test.Tasty.Hspec
+import Test.Tasty.TH
+
+import Tests.Arbitrary ()
+
+case_JidFromText :: Spec
+case_JidFromText = describe "jidFromText" $ do
+ it "parses a full JID" $ jidFromText "foo@bar.com/quux"
+ `shouldBe` Just (Jid (Just "foo")
+ "bar.com"
+ (Just "quux"))
+ it "parses a bare JID" $ jidFromText "foo@bar.com"
+ `shouldBe` Just (Jid (Just "foo")
+ "bar.com"
+ Nothing)
+ it "parses a domain" $ jidFromText "bar.com"
+ `shouldBe` Just (Jid Nothing
+ "bar.com"
+ Nothing)
+ it "parses domain with resource" $ jidFromText "bar.com/quux"
+ `shouldBe` Just (Jid Nothing
+ "bar.com"
+ (Just "quux"))
+ it "rejects multiple '@'" $ shouldReject "foo@bar@baz"
+ it "rejects multiple '/'" $ shouldReject "foo/bar/baz"
+ it "rejects multiple '/' after '@'" $ shouldReject "quux@foo/bar/baz"
+ it "rejects '@' after '/'" $ shouldReject "foo/bar@baz"
+ it "rejects empty local part" $ shouldReject "@bar/baz"
+ it "rejects empty resource part" $ shouldReject "foo@bar/"
+ it "rejects empty domain part" $ shouldReject "foo@/baz"
+ where shouldReject jid = jidFromText jid `shouldBe` Nothing
+
+prop_jidFromText_rightInverse :: Jid -> Bool
+prop_jidFromText_rightInverse j = let jidText = jidToText j in
+ (jidToText <$> jidFromText jidText) == Just jidText
+
+prop_jidFromText_leftInverse :: Jid -> Bool
+prop_jidFromText_leftInverse jid = (jidFromText $ jidToText jid) == Just jid
+
+
+case_LangTagParser :: Spec
+case_LangTagParser = describe "langTagFromText" $
+ it "has some properties" $ pendingWith "Check requirements"
+
+parserTests :: TestTree
+parserTests = $testGroupGenerator
View
95 tests/Tests/Picklers.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Tests.Picklers where
+
+import Tests.Arbitrary ()
+import Data.XML.Pickle
+import Network.Xmpp.Marshal
+import Network.Xmpp.Types
+import Test.Tasty
+import Test.Tasty.TH
+import Test.Tasty.QuickCheck
+
+import Data.XML.Types
+
+testPicklerInvertible :: Eq a => PU t a -> a -> Bool
+testPicklerInvertible p = \x -> case unpickle p (pickle p x) of
+ Left _ -> False
+ Right x' -> x == x'
+
+testPickler p x = case unpickle p (pickle p x) of
+ Left e -> putStrLn $ ppUnpickleError e
+ Right r -> putStrLn "OK."
+
+prop_errorConditionPicklerInvertible :: StanzaErrorCondition -> Bool
+prop_errorConditionPicklerInvertible = testPicklerInvertible xpErrorCondition
+
+prop_stanzaErrorPicklerInvertible :: StanzaError -> Bool
+prop_stanzaErrorPicklerInvertible = testPicklerInvertible xpStanzaError
+
+prop_messagePicklerInvertible :: Message -> Bool
+prop_messagePicklerInvertible = testPicklerInvertible xpMessage
+
+prop_messageErrorPicklerInvertible :: MessageError -> Bool
+prop_messageErrorPicklerInvertible = testPicklerInvertible xpMessageError
+
+prop_presencePicklerInvertible :: Presence -> Bool
+prop_presencePicklerInvertible = testPicklerInvertible xpPresence
+
+prop_presenceErrorPicklerInvertible :: PresenceError -> Bool
+prop_presenceErrorPicklerInvertible = testPicklerInvertible xpPresenceError
+
+prop_iqRequestPicklerInvertible :: IQRequest -> Bool
+prop_iqRequestPicklerInvertible = testPicklerInvertible xpIQRequest
+
+prop_iqResultPicklerInvertible :: IQResult -> Bool
+prop_iqResultPicklerInvertible = testPicklerInvertible xpIQResult
+
+prop_iqErrorPicklerInvertible :: IQError -> Bool
+prop_iqErrorPicklerInvertible = testPicklerInvertible xpIQError
+
+prop_langTagPicklerInvertible :: Maybe LangTag -> Bool
+prop_langTagPicklerInvertible = testPicklerInvertible xpLangTag
+
+prop_langPicklerInvertible :: LangTag -> Bool
+prop_langPicklerInvertible = testPicklerInvertible xpLang
+
+picklerTests :: TestTree
+picklerTests = $testGroupGenerator
+
+bad1 = StanzaError { stanzaErrorType = Cancel
+ , stanzaErrorCondition = Forbidden
+ , stanzaErrorText = Just $ (Just $ LangTag "v" [], "")
+ , stanzaErrorApplicationSpecificCondition =
+ Just (Element {elementName =
+ Name { nameLocalName = "\231"
+ , nameNamespace = Nothing
+ , namePrefix = Nothing}
+ , elementAttributes = []
+ , elementNodes = []
+ })
+ }
+
+bad2StanzaError = StanzaError { stanzaErrorType = Continue
+ , stanzaErrorCondition = NotAllowed
+ , stanzaErrorText = Just (Just $ parseLangTag "W-o","\f")
+ , stanzaErrorApplicationSpecificCondition =
+ Just (Element {elementName =
+ Name { nameLocalName = "\8204"
+ , nameNamespace = Nothing
+ , namePrefix = Just "\8417A"}
+ , elementAttributes = []
+ , elementNodes = []})}
+
+bad2 = MessageError { messageErrorID = Just ""
+ , messageErrorFrom = Just $ parseJid "a@y/\177"
+ , messageErrorTo = Just $ parseJid "\250@7"
+ , messageErrorLangTag = Nothing
+ , messageErrorStanzaError = bad2StanzaError
+ , messageErrorPayload =
+ [Element {elementName =
+ Name { nameLocalName = "\12226C"
+ , nameNamespace = Nothing
+ , namePrefix = Nothing}
+ , elementAttributes = []
+ , elementNodes = []}]}

0 comments on commit 2ac6736

Please sign in to comment.