pontarius-xmpp 0.5.2 → 0.5.3
raw patch · 5 files changed
+230/−46 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- pontarius-xmpp.cabal +4/−1
- tests/Run/Config.hs +36/−0
- tests/Run/Google.hs +47/−0
- tests/Run/SendReceive.hs +98/−0
- tests/Tests/Picklers.hs +45/−45
pontarius-xmpp.cabal view
@@ -1,5 +1,5 @@ Name: pontarius-xmpp-Version: 0.5.2+Version: 0.5.3 Cabal-Version: >= 1.9.2 Build-Type: Custom License: BSD3@@ -178,6 +178,9 @@ hs-source-dirs: tests main-is: Run.hs other-modules: Run.Payload+ , Run.SendReceive+ , Run.Google+ , Run.Config GHC-Options: -Wall -threaded Build-Depends: base , HUnit
+ tests/Run/Config.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Run.Config where++import qualified Data.Configurator as Conf+import qualified Data.Configurator.Types as Conf+import System.Directory+import System.FilePath+import System.Log.Logger+import qualified Data.Text as Text++-- | Load the configuration files+loadConfig :: IO Conf.Config+loadConfig = do+ appData <- getAppUserDataDirectory "pontarius-xmpp-tests"+ home <- getHomeDirectory+ Conf.load [ Conf.Optional $ appData </> "pontarius-xmpp-tests.conf"+ , Conf.Optional $ home </> ".pontarius-xmpp-tests.conf"+ ]++configuredLoglevel conf = do+ loglevel <- Conf.lookup conf "loglevel" >>= \case+ (Nothing :: Maybe Text.Text) -> return ERROR+ Just "debug" -> return DEBUG+ Just "info" -> return INFO+ Just "notice" -> return NOTICE+ Just "warning" -> return WARNING+ Just "error" -> return ERROR+ Just "critical" -> return CRITICAL+ Just "alert" -> return ALERT+ Just "emergency" -> return EMERGENCY+ Just e -> error $ "Log level " ++ (Text.unpack e) ++ " unknown"+ updateGlobalLogger "Pontarius.Xmpp" $ setLevel loglevel+ return loglevel
+ tests/Run/Google.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Test connecting to google services+module Run.Google where+++import qualified Data.Configurator as Conf+import Network.Xmpp+import Network.Xmpp.Lens+import System.Exit+import System.Log.Logger+import Test.HUnit+import Network.TLS++import Run.Config++xmppConf = set tlsServerIdentificationL ("talk.google.com", "") $ def++connectGoogle = do+ conf <- loadConfig+ _ <- configuredLoglevel conf+ infoM "Pontarius.Xmpp" "Trying to connect to google server"+ let realm = "google.com"+ user <- Conf.require conf "google.user"+ password <- Conf.require conf "google.password"+ mbSess <- session realm (simpleAuth user password) xmppConf+ sess <- case mbSess of+ Left e -> do+ assertFailure $ "google session could not be initialized" ++ show e+ exitFailure+ Right r -> return r+ infoM "Pontarius.Xmpp" "Done trying to connect to google server"++-- connectGoogleSCM = do+-- conf <- loadConfig+-- _ <- configuredLoglevel conf+-- infoM "Pontarius.Xmpp" "Trying to connect to google server"+-- let realm = "gcm.googleapis.com"+-- user <- Conf.require conf "google.user"+-- password <- Conf.require conf "google.password"+-- mbSess <- session realm (simpleAuth user password) xmppConf+-- sess <- case mbSess of+-- Left e -> do+-- assertFailure $ "google session could not be initialized" ++ show e+-- exitFailure+-- Right r -> return r+-- infoM "Pontarius.Xmpp" "Done trying to connect to google server"
+ tests/Run/SendReceive.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE LambdaCase #-}++module Run.SendReceive where++import Control.Applicative+import Control.Concurrent+import Control.Monad+import qualified Data.Configurator as Conf+import qualified Data.Configurator.Types as Conf+import Data.Maybe+import qualified Data.Text as Text+import Network+import Network.Xmpp+import System.Exit+import System.Log.Logger+import System.Timeout+import Test.HUnit+import Test.Hspec.Expectations++import Run.Payload+import Run.Config++xmppConfig :: ConnectionDetails -> SessionConfiguration+xmppConfig det = def{sessionStreamConfiguration+ = def{connectionDetails = det}+ , onConnectionClosed = \sess _ -> do+ _ <- reconnect' sess+ _ <- sendPresence presenceOnline sess+ return ()+ }++-- | reflect messages to their origin+reflect :: Session -> IO b+reflect sess = forever $ do+ m <- getMessage sess+ case answerMessage m (messagePayload m) of+ Nothing -> return ()+ Just am ->+ void $ sendMessage am{messageAttributes = messageAttributes m} sess++testAttributes = [( "{org.pontarius.xmpp.test}testattr"+ , "testvalue 12321 åäü>"+ )]++run :: IO ()+run = void $ do+ conf <- loadConfig+ uname1 <- Conf.require conf "xmpp.user1"+ pwd1 <- Conf.require conf "xmpp.password1"+ uname2 <- Conf.require conf "xmpp.user1"+ pwd2 <- Conf.require conf "xmpp.password1"+ realm <- Conf.require conf "xmpp.realm"+ server <- Conf.lookup conf "xmpp.server"+ port <- Conf.lookup conf "xmpp.port" :: IO (Maybe Integer)+ let conDetails = case server of+ Nothing -> UseRealm+ Just srv -> case port of+ Nothing -> UseSrv srv+ Just p -> UseHost srv (fromIntegral p)+ _ <- configuredLoglevel conf+ mbSess1 <- session realm (simpleAuth uname1 pwd1)+ ((xmppConfig conDetails))+ sess1 <- case mbSess1 of+ Left e -> do+ assertFailure $ "session 1 could not be initialized" ++ show e+ exitFailure+ Right r -> return r+ mbSess2 <- session realm (simpleAuth uname2 pwd2)+ ((xmppConfig conDetails))+ sess2 <- case mbSess2 of+ Left e -> do+ assertFailure $ "session 2 could not be initialized" ++ show e+ exitFailure+ Right r -> return r+ Just jid1 <- getJid sess1+ Just jid2 <- getJid sess2+ _ <- sendPresence presenceOnline sess1+ _ <- forkIO $ reflect sess1+ forkIO $ iqResponder sess1+ _ <- sendPresence presenceOnline sess2+ -- check message responsiveness+ infoM "Pontarius.Xmpp" "Running message mirror"+ sendMessage message{ messageTo = Just jid1+ , messageAttributes = testAttributes+ } sess2+ resp <- timeout 3000000 $ waitForMessage (\m -> messageFrom m == Just jid1)+ sess2+ case resp of+ Nothing -> assertFailure "Did not receive message answer"+ Just am -> messageAttributes am `shouldBe` testAttributes+ infoM "Pontarius.Xmpp" "Done running message mirror"+ infoM "Pontarius.Xmpp" "Running IQ tests"+ testPayload jid1 sess2+ infoM "Pontarius.Xmpp" "Done running IQ tests"
tests/Tests/Picklers.hs view
@@ -24,56 +24,56 @@ Left e -> putStrLn $ ppUnpickleError e Right _ -> putStrLn "OK." -prop_xpStreamStanza_invertibe :: Either StreamErrorInfo Stanza -> Bool-prop_xpStreamStanza_invertibe = tpsi xpStreamStanza-prop_xpStanza_invertibe :: Stanza -> Bool-prop_xpStanza_invertibe = tpsi xpStanza-prop_xpMessage_invertibe :: Message -> Bool-prop_xpMessage_invertibe = tpsi xpMessage-prop_xpPresence_invertibe = tpsi xpPresence-prop_xpPresence_invertibe :: Presence -> Bool-prop_xpIQRequest_invertibe = tpsi xpIQRequest-prop_xpIQRequest_invertibe :: IQRequest -> Bool-prop_xpIQResult_invertibe = tpsi xpIQResult-prop_xpIQResult_invertibe :: IQResult -> Bool-prop_xpErrorCondition_invertibe = tpsi xpStanzaErrorCondition-prop_xpErrorCondition_invertibe :: StanzaErrorCondition -> Bool-prop_xpStanzaError_invertibe = tpsi xpStanzaError-prop_xpStanzaError_invertibe :: StanzaError -> Bool-prop_xpMessageError_invertibe = tpsi xpMessageError-prop_xpMessageError_invertibe :: MessageError -> Bool-prop_xpPresenceError_invertibe = tpsi xpPresenceError-prop_xpPresenceError_invertibe :: PresenceError -> Bool-prop_xpIQError_invertibe = tpsi xpIQError-prop_xpIQError_invertibe :: IQError -> Bool-prop_xpStreamError_invertibe = tpsi xpStreamError-prop_xpStreamError_invertibe :: StreamErrorInfo -> Bool-prop_xpLangTag_invertibe = tpsi xpLangTag-prop_xpLangTag_invertibe :: Maybe LangTag -> Bool-prop_xpLang_invertibe = tpsi xpLang-prop_xpLang_invertibe :: LangTag -> Bool-prop_xpStream_invertibe = tpsi xpStream-prop_xpStream_invertibe :: ( Text+prop_xpStreamStanza_invertible :: Either StreamErrorInfo Stanza -> Bool+prop_xpStreamStanza_invertible = tpsi xpStreamStanza+prop_xpStanza_invertible :: Stanza -> Bool+prop_xpStanza_invertible = tpsi xpStanza+prop_xpMessage_invertible :: Message -> Bool+prop_xpMessage_invertible = tpsi xpMessage+prop_xpPresence_invertible = tpsi xpPresence+prop_xpPresence_invertible :: Presence -> Bool+prop_xpIQRequest_invertible = tpsi xpIQRequest+prop_xpIQRequest_invertible :: IQRequest -> Bool+prop_xpIQResult_invertible = tpsi xpIQResult+prop_xpIQResult_invertible :: IQResult -> Bool+prop_xpErrorCondition_invertible = tpsi xpStanzaErrorCondition+prop_xpErrorCondition_invertible :: StanzaErrorCondition -> Bool+prop_xpStanzaError_invertible = tpsi xpStanzaError+prop_xpStanzaError_invertible :: StanzaError -> Bool+prop_xpMessageError_invertible = tpsi xpMessageError+prop_xpMessageError_invertible :: MessageError -> Bool+prop_xpPresenceError_invertible = tpsi xpPresenceError+prop_xpPresenceError_invertible :: PresenceError -> Bool+prop_xpIQError_invertible = tpsi xpIQError+prop_xpIQError_invertible :: IQError -> Bool+prop_xpStreamError_invertible = tpsi xpStreamError+prop_xpStreamError_invertible :: StreamErrorInfo -> Bool+prop_xpLangTag_invertible = tpsi xpLangTag+prop_xpLangTag_invertible :: Maybe LangTag -> Bool+prop_xpLang_invertible = tpsi xpLang+prop_xpLang_invertible :: LangTag -> Bool+prop_xpStream_invertible = tpsi xpStream+prop_xpStream_invertible :: ( Text , Maybe Jid , Maybe Jid , Maybe Text , Maybe LangTag ) -> Bool-prop_xpJid_invertibe = tpsi xpJid-prop_xpJid_invertibe :: Jid -> Bool-prop_xpIQRequestType_invertibe = tpsi xpIQRequestType-prop_xpIQRequestType_invertibe :: IQRequestType -> Bool-prop_xpMessageType_invertibe = tpsi xpMessageType-prop_xpMessageType_invertibe :: MessageType -> Bool-prop_xpPresenceType_invertibe = tpsi xpPresenceType-prop_xpPresenceType_invertibe :: PresenceType -> Bool-prop_xpStanzaErrorType_invertibe = tpsi xpStanzaErrorType-prop_xpStanzaErrorType_invertibe :: StanzaErrorType -> Bool-prop_xpStanzaErrorCondition_invertibe = tpsi xpStanzaErrorCondition-prop_xpStanzaErrorCondition_invertibe :: StanzaErrorCondition -> Bool-prop_xpStreamErrorCondition_invertibe = tpsi xpStreamErrorCondition-prop_xpStreamErrorCondition_invertibe :: StreamErrorCondition -> Bool--- prop_xpStreamFeatures_invertibe = testPicklerInvertible xpStreamFeatures+prop_xpJid_invertible = tpsi xpJid+prop_xpJid_invertible :: Jid -> Bool+prop_xpIQRequestType_invertible = tpsi xpIQRequestType+prop_xpIQRequestType_invertible :: IQRequestType -> Bool+prop_xpMessageType_invertible = tpsi xpMessageType+prop_xpMessageType_invertible :: MessageType -> Bool+prop_xpPresenceType_invertible = tpsi xpPresenceType+prop_xpPresenceType_invertible :: PresenceType -> Bool+prop_xpStanzaErrorType_invertible = tpsi xpStanzaErrorType+prop_xpStanzaErrorType_invertible :: StanzaErrorType -> Bool+prop_xpStanzaErrorCondition_invertible = tpsi xpStanzaErrorCondition+prop_xpStanzaErrorCondition_invertible :: StanzaErrorCondition -> Bool+prop_xpStreamErrorCondition_invertible = tpsi xpStreamErrorCondition+prop_xpStreamErrorCondition_invertible :: StreamErrorCondition -> Bool+-- prop_xpStreamFeatures_invertible = testPicklerInvertible xpStreamFeatures picklerTests :: TestTree picklerTests = $testGroupGenerator