add tlsConnect function

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,42 +570,42 @@ 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
-
-  where
-    connectSrv host = do
-        case checkHostName (Text.pack host) of
-            Just host' -> do
-                resolvSeed <- lift $ makeResolvSeed (resolvConf config)
-                lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..."
-                srvRecords <- srvLookup host' resolvSeed
-                case srvRecords of
-                    Nothing -> do
-                        lift $ debugM "Pontarius.Xmpp"
-                            "No SRV records, using fallback process."
-                        lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host)
-                                                   5222
-                    Just srvRecords' -> do
-                        lift $ debugM "Pontarius.Xmpp"
-                            "SRV records found, performing A/AAAA lookups."
-                        lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords'
-            Nothing -> do
-                    lift $ errorM "Pontarius.Xmpp"
-                        "The hostname could not be validated."
-                    throwError XmppIllegalTcpDetails
+        UseConnection mkC -> Just <$> mkC
+
+connectSrv :: ResolvConf -> String -> ErrorT XmppFailure IO (Maybe Handle)
+connectSrv config host = do
+    case checkHostName (Text.pack host) of
+        Just host' -> do
+            resolvSeed <- lift $ makeResolvSeed config
+            lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..."
+            srvRecords <- srvLookup host' resolvSeed
+            case srvRecords of
+                Nothing -> do
+                    lift $ debugM "Pontarius.Xmpp"
+                        "No SRV records, using fallback process."
+                    lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host)
+                                               5222
+                Just srvRecords' -> do
+                    lift $ debugM "Pontarius.Xmpp"
+                        "SRV records found, performing A/AAAA lookups."
+                    lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords'
+        Nothing -> do
+                lift $ errorM "Pontarius.Xmpp"
+                    "The hostname could not be validated."
+                throwError XmppIllegalTcpDetails
 
 -- Connects to a list of addresses and ports. Surpresses any exceptions from
 -- connectTcp.

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 =