diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs new file mode 100644 index 0000000..aedf06d --- /dev/null +++ b/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] diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 0ede949..5986f67 100644 --- a/pontarius-xmpp.cabal +++ b/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 diff --git a/tests/DataForms.hs b/tests/DataForms.hs index b982bf8..320df0d 100644 --- a/tests/DataForms.hs +++ b/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 $ ["" ,"Bot Configuration" ,"Fill out this form to configure your new bot!" @@ -64,7 +64,7 @@ test1 = TL.concat $ ,"" ,""] -test2 = TL.concat [ +exampleXml2 = TL.concat [ " " ," " ," jabber:bot" @@ -98,7 +98,7 @@ test2 = TL.concat [ ," "] -test3 = TL.concat [ +exampleXml3 = TL.concat [ " " , " " , " jabber:bot" @@ -125,4 +125,4 @@ test3 = TL.concat [ , " " , " "] -parseForm = unpickleTree (xpRoot xpForm) . XML.NodeElement . Elements.parseElement \ No newline at end of file +parseForm = unpickleTree (xpRoot xpForm) . XML.NodeElement . Elements.parseElement diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 0000000..775ba6d --- /dev/null +++ b/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 + ] diff --git a/tests/Tests/Arbitrary.hs b/tests/Tests/Arbitrary.hs new file mode 100644 index 0000000..15c5ce5 --- /dev/null +++ b/tests/Tests/Arbitrary.hs @@ -0,0 +1,6 @@ +module Tests.Arbitrary where + +import Tests.Arbitrary.Xml () +import Tests.Arbitrary.Xmpp () + +-- $derive makeArbitrary IQRequestType diff --git a/tests/Tests/Arbitrary/Common.hs b/tests/Tests/Arbitrary/Common.hs new file mode 100644 index 0000000..126cb91 --- /dev/null +++ b/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) diff --git a/tests/Tests/Arbitrary/Xml.hs b/tests/Tests/Arbitrary/Xml.hs new file mode 100644 index 0000000..cdb6004 --- /dev/null +++ b/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] diff --git a/tests/Tests/Arbitrary/Xmpp.hs b/tests/Tests/Arbitrary/Xmpp.hs new file mode 100644 index 0000000..0625602 --- /dev/null +++ b/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 + ] diff --git a/tests/Tests/Parsers.hs b/tests/Tests/Parsers.hs new file mode 100644 index 0000000..7081d6d --- /dev/null +++ b/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 diff --git a/tests/Tests/Picklers.hs b/tests/Tests/Picklers.hs new file mode 100644 index 0000000..b965b81 --- /dev/null +++ b/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 = []}]}