From 2548c943106a2f9e2982072fdb06b4c04b8ab215 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Tue, 12 Mar 2013 02:36:36 +0100 Subject: [PATCH] Add TLS behaviour and settings to the `StreamConfiguration' object --- examples/echoclient/Main.hs | 1 - source/Network/Xmpp.hs | 2 -- source/Network/Xmpp/Concurrent.hs | 12 +++++------- source/Network/Xmpp/Tls.hs | 13 ++++--------- source/Network/Xmpp/Types.hs | 26 ++++++++++++++++++++++---- 5 files changed, 31 insertions(+), 23 deletions(-) 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.