Add TLS behaviour and settings to the `StreamConfiguration' object

examples/echoclient/Main.hs

@@ -53,7 +53,6 @@ main = do
     sess' <- session
                 realm
                 def
-                Nothing -- (Just exampleParams)
                 (Just ([scramSha1 username Nothing password], resource))
     sess <- case sess' of
         Left err -> error $ "Error connection to XMPP server: " ++ show err

source/Network/Xmpp.hs

@@ -147,8 +147,6 @@ module Network.Xmpp
   , dupSession
   -- * Miscellaneous
   , LangTag(..)
-  , exampleParams
-  , PortID(..)
   , XmppFailure(..)
   , StreamErrorInfo(..)
   , StreamErrorCondition(..)

source/Network/Xmpp/Concurrent.hs

@@ -130,18 +130,16 @@ writeWorker stCh writeR = forever $ do
 -- acquire an XMPP resource.
 session :: HostName                          -- ^ The hostname / realm
         -> SessionConfiguration              -- ^ configuration details
-        -> Maybe TLS.TLSParams               -- ^ TLS settings, if securing the
-                                             -- connection to the server is
-                                             -- desired
         -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired
                                              -- JID resource (or Nothing to let
                                              -- the server decide)
         -> IO (Either XmppFailure (Session, Maybe AuthFailure))
-session realm config mbTls mbSasl = runErrorT $ do
+session realm config mbSasl = runErrorT $ do
     stream <- ErrorT $ openStream realm (sessionStreamConfiguration config)
-    case mbTls of
-        Nothing -> return ()
-        Just tls -> ErrorT $ startTls tls stream
+    case sessionTlsBehaviour config of
+        RequireTls -> ErrorT $ startTls stream -- TODO: Check if server feature available
+        PreferTls -> ErrorT $ startTls stream -- TODO: Check if server feature available
+        RefuseTls -> return ()
     aut <- case mbSasl of
         Nothing -> return Nothing
         Just (handlers, resource) -> ErrorT $ auth handlers resource stream

source/Network/Xmpp/Tls.hs

@@ -37,21 +37,16 @@ mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)
 starttlsE :: Element
 starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
 
-exampleParams :: TLSParams
-exampleParams = defaultParamsClient
-    { pConnectVersion    = TLS12
-    , pAllowedVersions   = [TLS12]
-    , pCiphers           = ciphersuite_strong
-    }
-
 -- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and
 -- restarts the stream.
-startTls :: TLSParams -> TMVar Stream -> IO (Either XmppFailure ())
-startTls params con = Ex.handle (return . Left . TlsError)
+startTls :: TMVar Stream -> IO (Either XmppFailure ())
+startTls con = Ex.handle (return . Left . TlsError)
                       . flip withStream con
                       . runErrorT $ do
     lift $ lift $ debugM "Pontarius.XMPP" "startTls: Securing stream..."
     features <- lift $ gets streamFeatures
+    config <- lift $ gets streamConfiguration
+    let params = tlsParams config
     state <- gets streamState
     case state of
         Plain -> return ()

source/Network/Xmpp/Types.hs

@@ -47,6 +47,7 @@ module Network.Xmpp.Types
     , Hostname(..)
     , hostname
     , SessionConfiguration(..)
+    , TlsBehaviour(..)
     )
        where
 
@@ -67,7 +68,8 @@ import qualified Data.Text as Text
 import           Data.Typeable(Typeable)
 import           Data.XML.Types
 
-import qualified Network.TLS as TLS
+import           Network.TLS hiding (Version)
+import           Network.TLS.Extra
 
 import qualified Network as N
 
@@ -666,7 +668,7 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
                                         -- failed.
                  | XmppIllegalTcpDetails -- ^ The TCP details provided did not
                                          -- validate.
-                 | TlsError TLS.TLSError -- ^ An error occurred in the
+                 | TlsError TLSError -- ^ An error occurred in the
                                      -- TLS layer
                  | TlsNoServerSupport -- ^ The server does not support
                                       -- the use of TLS
@@ -1042,6 +1044,8 @@ data StreamConfiguration =
                           -- session bind as defined in the (outdated)
                           -- RFC 3921 specification
                         , establishSession :: Bool
+                          -- | Settings to be used for TLS negotitation
+                        , tlsParams :: TLSParams
                         }
 
 
@@ -1051,6 +1055,10 @@ instance Default StreamConfiguration where
                               , socketDetails = Nothing
                               , resolvConf = defaultResolvConf
                               , establishSession = False
+                              , tlsParams = defaultParamsClient { pConnectVersion = TLS12
+                                                                , pAllowedVersions = [TLS12]
+                                                                , pCiphers = ciphersuite_strong
+                                                                }
                               }
 
 data Hostname = Hostname Text deriving (Eq, Show)
@@ -1095,7 +1103,10 @@ data SessionConfiguration = SessionConfiguration
       sessionStreamConfiguration :: StreamConfiguration
       -- | Handler to be run when the session ends (for whatever reason).
     , sessionClosedHandler :: XmppFailure -> IO ()
+      -- | Function to generate the stream of stanza identifiers.
     , sessionStanzaIDs :: IO StanzaID
+      -- | How the client should behave in regards to TLS.
+    , sessionTlsBehaviour :: TlsBehaviour
     }
 
 instance Default SessionConfiguration where
@@ -1106,4 +1117,11 @@ instance Default SessionConfiguration where
                                      atomically $ do
                                          curId <- readTVar idRef
                                          writeTVar idRef (curId + 1 :: Integer)
-                                         return . read. show $ curId}
+                                         return . read. show $ curId
+                               , sessionTlsBehaviour = PreferTls }
+
+-- | How the client should behave in regards to TLS.
+data TlsBehaviour = RequireTls -- ^ Require the use of TLS; disconnect if it's
+                               -- not offered.
+                  | PreferTls  -- ^ Negotitate TLS if it's available.
+                  | RefuseTls  -- ^ Never secure the stream with TLS.