fix connection to google talk servers failing

google talk only supports RC4 as TLS cipher

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

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)

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

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
+-- | Default parameters for TLS restricted to strong ciphers
-xmppDefaultParams :: ClientParams
+xmppDefaultParamsStrong :: ClientParams
-xmppDefaultParams = (defaultParamsClient "" BS.empty)
+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

tests/Run.hs

@@ -1,119 +1,14 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE LambdaCase #-}
-
 module Main where
 
-import           Control.Applicative
+import Test.Tasty.HUnit
-import           Control.Concurrent
+import Test.Tasty
-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"
-              ]
 
--- | reflect messages to their origin
+import qualified Run.SendReceive as SendReceive
-reflect :: Session -> IO b
+import qualified Run.Google as Google
-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"
+sendReceiveTest = testCase "send and receive" SendReceive.run
-                  , "testvalue  12321 åäü>"
+googleTest = testCase "connect to google service" Google.connectGoogle
-                  )]
 
-main :: IO ()
+main = defaultMain $ testGroup "connection tests" [ sendReceiveTest
-main = void $ do
+                                                  , googleTest
-    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"

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

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"

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"