From 94c78454daaed3b7c0044c0ae798bfd313277764 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 10 Oct 2015 16:54:39 +0200 Subject: [PATCH] add Test.Arbitrary.Common module to cabal file --- pontarius-xmpp.cabal | 1 + tests/Tests/Common.hs | 58 --------------- tests/Tests/Echo.hs | 168 ------------------------------------------ 3 files changed, 1 insertion(+), 226 deletions(-) delete mode 100644 tests/Tests/Common.hs delete mode 100644 tests/Tests/Echo.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 810f309..0fba29e 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -152,6 +152,7 @@ Test-Suite tests , xml-types HS-Source-Dirs: tests Other-modules: Tests.Arbitrary + , Tests.Arbitrary.Common , Tests.Arbitrary.Xml , Tests.Arbitrary.Xmpp , Tests.Parsers diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs deleted file mode 100644 index 9d3dbe4..0000000 --- a/tests/Tests/Common.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# 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 deleted file mode 100644 index de691b0..0000000 --- a/tests/Tests/Echo.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# 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