From 081cc1b2cf249d1b2aca32357dd69cfa01ac9ff7 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Dec 2013 23:30:52 +0100 Subject: [PATCH] update tests --- pontarius-xmpp.cabal | 8 ++ tests/Tests/Common.hs | 58 +++++++++++++++ tests/Tests/Echo.hs | 168 ++++++++++++++++++++++++++++++++++++++++++ tests/Tests/Stream.hs | 40 ++++++++++ 4 files changed, 274 insertions(+) create mode 100644 tests/Tests/Common.hs create mode 100644 tests/Tests/Echo.hs create mode 100644 tests/Tests/Stream.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 376a3dc..bb466ab 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -123,21 +123,29 @@ Test-Suite tests , Cabal , QuickCheck , async + , async , conduit , containers + , data-default , derive + , hslogger , hspec , hspec-expectations + , lens + , network , pontarius-xmpp , quickcheck-instances , ranges , smallcheck + , stm , stringprep >= 0.1.5 , tasty , tasty-hspec + , tasty-hunit , tasty-quickcheck , tasty-th , text + , transformers , xml-picklers , xml-types HS-Source-Dirs: tests diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs new file mode 100644 index 0000000..9d3dbe4 --- /dev/null +++ b/tests/Tests/Common.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Tests.Common where + +import Control.Concurrent.Async +import Control.Exception as Ex +import Data.Default +import Data.Maybe (fromJust) +import qualified Data.Text as Text +import Data.Typeable (Typeable) +import Network +import Network.Xmpp +import Test.Hspec + +timeoutDuration :: Num a => a +timeoutDuration = 3000000 + +initiator :: Jid +initiator = [jidQ|echo1@species64739.dyndns.org/bot|] + +responder :: Jid +responder = [jidQ|echo2@species64739.dyndns.org/bot|] + +data TestAssertionFailed = TestAssertionFailed String deriving (Show, Eq, Typeable) +instance Exception TestAssertionFailed + +assertionFailed :: String -> IO a +assertionFailed = throwIO . TestAssertionFailed + +config :: SessionConfiguration +config = def{sessionStreamConfiguration + = def{connectionDetails = UseHost "localhost" (PortNumber 5222)}} + +createSession :: Jid -> IO Session +createSession we = do + context' <- session (Text.unpack $ domainpart we) + (Just ( \_ -> [scramSha1 (fromJust $ localpart we) Nothing "pwd"] + , resourcepart we)) config + sess <- case context' of + Left _e -> assertionFailed "Session could not be initialized" + Right r -> return r + _ <- sendPresence presenceOnline sess `shouldReturn` (Right ()) + return sess + +prepareThreads :: (Session -> IO a) -> (Session -> IO c) -> IO c +prepareThreads resp ini = bracket (createSession responder) + endSession + (\respSession -> withAsync (resp respSession) $ + \_ -> bracket (createSession initiator) + endSession + ini) + + +-- startUp = do +-- thread1 <- forkIO $ diff --git a/tests/Tests/Echo.hs b/tests/Tests/Echo.hs new file mode 100644 index 0000000..de691b0 --- /dev/null +++ b/tests/Tests/Echo.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tests.Echo where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import qualified Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp +import Network.Xmpp.Marshal (pickleElem, unpickleElem) +import System.Log.Logger +import System.Timeout +import Test.Hspec +import Tests.Common + +testNS :: Text.Text +testNS = "xmpp:library:test" + +testName :: Text.Text -> Name +testName name = Name name (Just testNS) Nothing + +data Payload = Payload + { _payloadWantError :: Bool + , _payloadWantTimeout :: Bool + , _payloadText :: Text.Text + } deriving (Eq, Show) + +makeLenses ''Payload + +defaultPL :: Payload +defaultPL = Payload False False "ping" + +-- | Automatically accept all subscription requests from other entities +autoAccept :: Session -> IO () +autoAccept sess = forever $ do + st <- waitForPresence ((== Subscribe ) . presenceType ) sess + case presenceFrom st of + Just fr -> do + _ <- sendPresence (presenceSubscribed fr) sess + return () + Nothing -> return () -- this shouldn't happen + +payloadP :: PU [Node] Payload +payloadP = xpWrap (\((err, tout) , msg) -> Payload err tout msg) + (\(Payload err tout msg) -> + ((err, tout) , msg)) $ + xpElem (Name "request" (Just testNS) Nothing) + (xp2Tuple + (xpAttr "want-error" xpPrim) + (xpAttr "want-timeout" xpPrim) + ) + (xpElemNodes (Name "message" (Just testNS) Nothing) + (xpContent xpId)) + +iqResponder :: Session -> IO b +iqResponder sess = do + chan' <- listenIQChan Set testNS sess + chan <- case chan' of + Left _ -> assertionFailed "Channel was already taken" + Right c -> return c + forever . void . runMaybeT $ do + next <- liftIO . atomically $ readTChan chan + let Right pld = unpickleElem payloadP . iqRequestPayload $ + iqRequestBody next + when (pld^.payloadWantTimeout) mzero + let answerPayload = Payload False False (Text.reverse $ pld^.payloadText) + let answerBody = pickleElem payloadP answerPayload + let answer = case pld^.payloadWantError of + True -> Left $ mkStanzaError UndefinedCondition + False -> Right $ Just answerBody + liftIO $ answerIQ next answer + +mirror :: Session -> IO b +mirror sess = forever $ do + msg <- getMessage sess + case (answerMessage msg (view payload msg)) of + Nothing -> return () + Just answer -> void $ sendMessage answer sess + +resp :: Session -> IO b +resp sess = + withAsync (iqResponder sess) $ \_ -> + mirror sess + + +--------------------------------------- +-- Tests ------------------------------ +--------------------------------------- + +test_messagePing :: Session -> IO () +test_messagePing sess = do + infoM "Pontarius.Xmpp.Tests" "RUNNING message ping test" + let el = [Element (testName "ping") [] []] + _ <- sendMessage (message{ messagePayload = el + , messageTo = Just responder + }) sess + mbMessage <- timeout timeoutDuration (getMessage sess) + case mbMessage of + Nothing -> assertionFailed $ "ping: No answer within " + ++ show (timeoutDuration `div` 1000000 :: Integer) ++ "seconds" + Just msg -> view payload msg `shouldBe` el + infoM "Pontarius.Xmpp.Tests" "SUCCESS message ping test" + +test_IQ :: Payload + -> Session + -> IO (Either IQSendError IQResponse) +test_IQ pl sess = do + let el = pickleElem payloadP pl + sendIQ' (Just timeoutDuration) (Just responder) Set Nothing el sess + +test_IQPing :: Session -> IO () +test_IQPing sess = do + infoM "Pontarius.Xmpp.Tests" "RUNNING IQ ping test" + response <- test_IQ defaultPL sess + case response of + Left e -> assertionFailed $ "test_IQPing: " ++ show e + Right (IQResponseError e) -> assertionFailed $ "iqPing: " ++ show e + Right (IQResponseResult r) -> do + case view payload r of + Nothing -> assertionFailed "test_IQPing: no payload" + Just pl' -> case unpickleElem payloadP pl' of + Left e -> assertionFailed $ "test_IQPing: unpickling\ + \returned unpickleError" ++ show e + Right pl -> pl `shouldBe` Payload False False "gnip" + infoM "Pontarius.Xmpp.Tests" "SUCCESS IQ ping test" + +test_IQError :: Session -> IO () +test_IQError sess = do + infoM "Pontarius.Xmpp.Tests" "RUNNING IQ Error test" + response <- test_IQ (defaultPL & payloadWantError .~ True) sess + case response of + Left e -> assertionFailed $ "iqPing: " ++ show e + Right (IQResponseError e) -> e^.stanzaError.stanzaErrorConditionL + `shouldBe` UndefinedCondition + Right (IQResponseResult r) -> assertionFailed $ "test_IQError:\ + \Expected IQ error but got" ++ show r + infoM "Pontarius.Xmpp.Tests" "SUCCESS IQ Error test" + +test_IQTimeout :: Session -> IO () +test_IQTimeout sess = do + infoM "Pontarius.Xmpp.Tests" "RUNNING IQ Timeout test" + response <- test_IQ (defaultPL & payloadWantTimeout .~ True) sess + case response of + Left IQTimeOut -> return () + err -> assertionFailed $ "test_IQTimeout: Expected timeout but got" + ++ show err + infoM "Pontarius.Xmpp.Tests" "SUCCESS IQ Timeout test" + + +tests :: Session -> IO () +tests sess = do + infoM "Pontarius.Xmpp.Tests" "RUNNING test barrage" + test_messagePing sess + test_IQPing sess + test_IQError sess + test_IQTimeout sess + infoM "Pontarius.Xmpp.Tests" "SUCCESS test barrage" + +test :: IO () +test = do + updateGlobalLogger "Pontarius.Xmpp" $ setLevel INFO + prepareThreads resp tests diff --git a/tests/Tests/Stream.hs b/tests/Tests/Stream.hs new file mode 100644 index 0000000..fae939b --- /dev/null +++ b/tests/Tests/Stream.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tests.Stream where + +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.XML.Types +import Test.Hspec +import Test.Tasty.TH +import Test.Tasty +import Test.Tasty.Hspec + +import Network.Xmpp.Stream + +junk = [ EventBeginDocument + , EventEndDocument + , EventBeginDoctype "" Nothing + , EventEndDoctype + , EventInstruction $ Instruction "" "" +-- , EventBeginElement Name [(Name, [Content])] + , EventEndElement "foo" + , EventContent $ ContentText "" + , EventComment "" + , EventCDATA "" + ] + +beginElem = EventBeginElement "foo" [] + +case_ThrowOutJunk = do + it "drops everything but EvenBeginElement" $ do + res <- CL.sourceList junk $$ throwOutJunk >> await + res `shouldBe` Nothing + it "keeps everything after (and including) EvenBeginElement" $ do + res <- CL.sourceList (junk ++ [beginElem] ++ junk) + $$ throwOutJunk >> CL.consume + res `shouldBe` (beginElem : junk) + +testStreams :: TestTree +testStreams = $testGroupGenerator