diff --git a/examples/echoclient/Main.hs b/examples/echoclient/Main.hs
index a168968..455d4ca 100644
--- a/examples/echoclient/Main.hs
+++ b/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
diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs
index 6d73c2a..62b5595 100644
--- a/source/Network/Xmpp.hs
+++ b/source/Network/Xmpp.hs
@@ -147,8 +147,6 @@ module Network.Xmpp
, dupSession
-- * Miscellaneous
, LangTag(..)
- , exampleParams
- , PortID(..)
, XmppFailure(..)
, StreamErrorInfo(..)
, StreamErrorCondition(..)
diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs
index 1fa0c90..6597b12 100644
--- a/source/Network/Xmpp/Concurrent.hs
+++ b/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
diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs
index 2df3547..ada6220 100644
--- a/source/Network/Xmpp/Tls.hs
+++ b/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 ", waits for "", 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 ()
diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs
index c230b06..e7d95ea 100644
--- a/source/Network/Xmpp/Types.hs
+++ b/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,8 +668,8 @@ 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
- -- TLS layer
+ | TlsError TLSError -- ^ An error occurred in the
+ -- TLS layer
| TlsNoServerSupport -- ^ The server does not support
-- the use of TLS
| XmppNoStream -- ^ An action that required an active
@@ -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.