Merge branch 'master' into upstream

source/Network/Xmpp.hs

@@ -32,6 +32,8 @@ module Network.Xmpp
   , StreamConfiguration(..)
   , SessionConfiguration(..)
   , ConnectionDetails(..)
+  , closeConnection
+  , endSession
     -- TODO: Close session, etc.
     -- ** Authentication handlers
     -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be
@@ -39,8 +41,6 @@ module Network.Xmpp
   , scramSha1
   , plain
   , digestMd5
-  , closeConnection
-  , endSession
   -- * Addressing
   -- | A JID (historically: Jabber ID) is XMPPs native format
   -- for addressing entities in the network. It is somewhat similar to an e-mail
@@ -184,6 +184,7 @@ module Network.Xmpp
                , AuthOtherFailure )
   , SaslHandler
   , ConnectionState(..)
+  , connectTls
   ) where
 
 import Network.Xmpp.Concurrent
@@ -191,3 +192,4 @@ import Network.Xmpp.Sasl
 import Network.Xmpp.Sasl.Types
 import Network.Xmpp.Stanza
 import Network.Xmpp.Types
+import Network.Xmpp.Tls

source/Network/Xmpp/Stream.hs

@@ -570,26 +570,26 @@ connect realm config = do
                     liftIO $ hSetBuffering h' NoBuffering
                     return . Just $ handleToStreamHandle h'
         UseSrv host -> do
-            h <- connectSrv host
+            h <- connectSrv (resolvConf config) host
             case h of
                 Nothing -> return Nothing
                 Just h' -> do
                     liftIO $ hSetBuffering h' NoBuffering
                     return . Just $ handleToStreamHandle h'
         UseRealm -> do
-            h <- connectSrv realm
+            h <- connectSrv (resolvConf config) realm
             case h of
                 Nothing -> return Nothing
                 Just h' -> do
                     liftIO $ hSetBuffering h' NoBuffering
                     return . Just $ handleToStreamHandle h'
-        UseConnection mkC -> Just <$> liftIO mkC
+        UseConnection mkC -> Just <$> mkC
 
-  where
-    connectSrv host = do
+connectSrv :: ResolvConf -> String -> ErrorT XmppFailure IO (Maybe Handle)
+connectSrv config host = do
     case checkHostName (Text.pack host) of
         Just host' -> do
-                resolvSeed <- lift $ makeResolvSeed (resolvConf config)
+            resolvSeed <- lift $ makeResolvSeed config
             lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..."
             srvRecords <- srvLookup host' resolvSeed
             case srvRecords of

source/Network/Xmpp/Tls.hs

@@ -15,6 +15,7 @@ import qualified Data.ByteString.Lazy as BL
 import           Data.Conduit
 import           Data.IORef
 import           Data.XML.Types
+import           Network.DNS.Resolver (ResolvConf)
 import           Network.TLS
 import           Network.Xmpp.Stream
 import           Network.Xmpp.Types
@@ -154,3 +155,23 @@ mkReadBuffer recv = do
             writeIORef buffer rest
             return result
     return read'
+
+-- | Connect to an XMPP server and secure the connection with TLS before
+-- starting the XMPP streams
+connectTls :: ResolvConf -- ^ Resolv conf to use (try defaultResolvConf as a
+                         -- default)
+           -> TLSParams  -- ^ TLS parameters to use when securing the connection
+           -> String     -- ^ Host to use when connecting (will be resolved
+                         -- using SRV records)
+           -> ErrorT XmppFailure IO StreamHandle
+connectTls config params host = do
+    h <- connectSrv config host >>= \h' -> case h' of
+        Nothing -> throwError TcpConnectionFailure
+        Just h'' -> return h''
+    let hand = handleToStreamHandle h
+    (_raw, _snk, psh, recv, ctx) <- tlsinit params $ mkBackend hand
+    return $ StreamHandle { streamSend = catchPush . psh
+                          , streamReceive = recv
+                          , streamFlush = contextFlush ctx
+                          , streamClose = bye ctx >> streamClose hand
+                          }

source/Network/Xmpp/Types.hs

@@ -1007,7 +1007,7 @@ instance Exception InvalidXmppXml
 data ConnectionDetails = UseRealm -- ^ Use realm to resolv host
                        | UseSrv HostName -- ^ Use this hostname for a SRV lookup
                        | UseHost HostName PortID -- ^ Use specified host
-                       | UseConnection (IO StreamHandle)
+                       | UseConnection (ErrorT XmppFailure IO StreamHandle)
 
 -- | Configuration settings related to the stream.
 data StreamConfiguration =