add test cases and benchmarks

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]

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

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

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
+                                      ]

tests/Tests/Arbitrary.hs

@@ -0,0 +1,6 @@
+module Tests.Arbitrary  where
+
+import Tests.Arbitrary.Xml ()
+import Tests.Arbitrary.Xmpp ()
+
+-- $derive makeArbitrary IQRequestType

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)

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]

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
+                                       ]

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

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 = []}]}