From 91b8d1b5ae8e6cc9ac9af9838fc5981b67537d66 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 9 Mar 2014 12:37:09 +0100 Subject: [PATCH] fix connection to google talk servers failing google talk only supports RC4 as TLS cipher --- pontarius-xmpp.cabal | 8 +-- source/Network/Xmpp/Stream.hs | 6 +- source/Network/Xmpp/Tls.hs | 7 +- source/Network/Xmpp/Types.hs | 16 +++-- tests/Run.hs | 123 +++------------------------------- tests/Run/Config.hs | 36 ++++++++++ tests/Run/Google.hs | 48 +++++++++++++ tests/Run/SendReceive.hs | 98 +++++++++++++++++++++++++++ 8 files changed, 216 insertions(+), 126 deletions(-) create mode 100644 tests/Run/Config.hs create mode 100644 tests/Run/Google.hs create mode 100644 tests/Run/SendReceive.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 7eb9bbb..2f0995e 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -36,11 +36,6 @@ Flag with-th { Library hs-source-dirs: source Exposed: True - - -- The only different between the below two blocks is that the first one caps - -- the range for the `bytestring' package, and that the second one includes - -- `template-haskell' for GHC 7.6.1 and above. - Build-Depends: attoparsec >=0.10.0.3 , base >4 && <5 , base64-bytestring >=0.1.0.0 @@ -189,6 +184,9 @@ Test-Suite runtests , text , xml-picklers , xml-types + , tasty + , tasty-hunit + , tls benchmark benchmarks type: exitcode-stdio-1.0 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 9c35131..ebd19b8 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -521,6 +521,7 @@ createStream realm config = do Just (host, hand) -> ErrorT $ do debugM "Pontarius.Xmpp" "Acquired handle." debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." + debugM "Pontarius.Xmpp" $ "Setting TLS expected host to " ++ show host eSource <- liftIO . bufferSrc $ (sourceStreamHandle hand $= logConduit) $= XP.parseBytes def @@ -631,10 +632,11 @@ connectTcp ((address, port):remainder) = do connectTo address port) :: IO (Either Ex.IOException Handle) case result of Right handle -> do - debugM "Pontarius.Xmpp" "Successfully connected to HostName." + debugM "Pontarius.Xmpp" $ "Successfully connected to " ++ show address return $ Just handle Left _ -> do - debugM "Pontarius.Xmpp" "Connection to HostName could not be established." + debugM "Pontarius.Xmpp" $ + "Connection to " ++ show address ++ " could not be established." connectTcp remainder #if MIN_VERSION_dns(1, 0, 0) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 2d2f044..15f2524 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -179,7 +179,12 @@ connectTls config params host = do Nothing -> throwError TcpConnectionFailure Just h'' -> return h'' let hand = handleToStreamHandle h - (_raw, _snk, psh, recv, ctx) <- tlsinit params $ mkBackend hand + let params' = params{clientServerIdentification + = case clientServerIdentification params of + ("", _) -> (host, "") + csi -> csi + } + (_raw, _snk, psh, recv, ctx) <- tlsinit params' $ mkBackend hand return $ ( hn , StreamHandle { streamSend = catchPush . psh , streamReceive = wrapExceptions . recv diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 6fa1045..6db6e6f 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1195,18 +1195,26 @@ data StreamConfiguration = , tlsParams :: ClientParams } --- | Default parameters for TLS. Those are the default client parameters from the tls package with the ciphers set to ciphersuite_strong -xmppDefaultParams :: ClientParams -xmppDefaultParams = (defaultParamsClient "" BS.empty) +-- | Default parameters for TLS restricted to strong ciphers +xmppDefaultParamsStrong :: ClientParams +xmppDefaultParamsStrong = (defaultParamsClient "" BS.empty) { clientSupported = def { supportedCiphers = ciphersuite_strong ++ [ cipher_AES256_SHA1 , cipher_AES128_SHA1 ] } - , clientUseServerNameIndication = True } +-- | Default parameters for TLS +xmppDefaultParams :: ClientParams +xmppDefaultParams = (defaultParamsClient "" BS.empty) + { clientSupported = def + { supportedCiphers = ciphersuite_all + } + } + + instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing diff --git a/tests/Run.hs b/tests/Run.hs index fcc281e..796103e 100644 --- a/tests/Run.hs +++ b/tests/Run.hs @@ -1,119 +1,14 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE LambdaCase #-} - module Main 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.Directory -import System.Exit -import System.FilePath -import System.Log.Logger -import System.Timeout -import Test.HUnit -import Test.Hspec.Expectations - -import Run.Payload - -xmppConfig :: ConnectionDetails -> SessionConfiguration -xmppConfig det = def{sessionStreamConfiguration - = def{connectionDetails = det} - , onConnectionClosed = \sess _ -> do - _ <- reconnect' sess - _ <- sendPresence presenceOnline sess - return () - } - --- | 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" - ] +import Test.Tasty.HUnit +import Test.Tasty --- | 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 +import qualified Run.SendReceive as SendReceive +import qualified Run.Google as Google -testAttributes = [( "{org.pontarius.xmpp.test}testattr" - , "testvalue 12321 åäü>" - )] +sendReceiveTest = testCase "send and receive" SendReceive.run +googleTest = testCase "connect to google service" Google.connectGoogle -main :: IO () -main = 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 (PortNumber $ fromIntegral p) - 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 - 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" +main = defaultMain $ testGroup "connection tests" [ sendReceiveTest + , googleTest + ] diff --git a/tests/Run/Config.hs b/tests/Run/Config.hs new file mode 100644 index 0000000..14e97a4 --- /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 index 0000000..5d12567 --- /dev/null +++ b/tests/Run/Google.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Test connecting to google services +module Run.Google where + + +import qualified Data.Configurator as Conf +import Network.Xmpp +import System.Exit +import System.Log.Logger +import Test.HUnit +import Network.TLS + +import Run.Config + +xmppConf = def {sessionStreamConfiguration = + def{tlsParams = (tlsParams def){clientUseServerNameIndication = False}} + } + +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 index 0000000..8f4794b --- /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 (PortNumber $ 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"