diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -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 diff --git a/tests/Run/Config.hs b/tests/Run/Config.hs new file mode 100644 --- /dev/null +++ b/tests/Run/Config.hs @@ -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 diff --git a/tests/Run/Google.hs b/tests/Run/Google.hs new file mode 100644 --- /dev/null +++ b/tests/Run/Google.hs @@ -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" diff --git a/tests/Run/SendReceive.hs b/tests/Run/SendReceive.hs new file mode 100644 --- /dev/null +++ b/tests/Run/SendReceive.hs @@ -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" diff --git a/tests/Tests/Picklers.hs b/tests/Tests/Picklers.hs --- a/tests/Tests/Picklers.hs +++ b/tests/Tests/Picklers.hs @@ -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