From 8875fca4d7ecd4dd6584ad9929cc9e04419ff2f2 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 13 Mar 2013 12:26:31 +0100 Subject: [PATCH] move TLS preference check to startTLS and add PreferPlain --- source/Network/Xmpp/Concurrent.hs | 19 +------ source/Network/Xmpp/Internal.hs | 2 +- source/Network/Xmpp/Tls.hs | 94 ++++++++++++++++--------------- source/Network/Xmpp/Types.hs | 9 ++- 4 files changed, 56 insertions(+), 68 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 7242e4c..28ecf70 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -137,24 +137,7 @@ session :: HostName -- ^ The hostname / realm -> IO (Either XmppFailure (Session, Maybe AuthFailure)) session realm config mbSasl = runErrorT $ do stream <- ErrorT $ openStream realm (sessionStreamConfiguration config) - tlsFeat <- ErrorT $ withStream' (get >>= \stream' -> return $ Right $ streamTls $ streamFeatures stream') stream - case sessionTlsBehaviour config of - RequireTls -> do - case tlsFeat of - Nothing -> do - lift $ errorM "Pontarius.XMPP" "TLS is required by the client but not offered by the server." >> return () - throwError TlsNoServerSupport - Just _ -> ErrorT $ startTls stream - PreferTls -> do - case tlsFeat of - Nothing -> return () - Just _ -> ErrorT $ startTls stream - RefuseTls -> do - case tlsFeat of - Just True -> do - lift $ errorM "Pontarius.XMPP" "TLS is refused by the client but required by the server." - throwError XmppOtherFailure - _ -> return () + ErrorT $ tls stream aut <- case mbSasl of Nothing -> return Nothing Just (handlers, resource) -> ErrorT $ auth handlers resource stream diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs index 6f596d9..60f7fbc 100644 --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -24,7 +24,7 @@ module Network.Xmpp.Internal , StreamFeatures(..) , openStream , withStream - , startTls + , tls , auth , pushStanza , pullStanza diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index ada6220..3748a35 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -4,29 +4,25 @@ module Network.Xmpp.Tls where +import Control.Concurrent.STM.TMVar import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict - +import Crypto.Random.API import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BSC8 +import qualified Data.ByteString.Lazy as BL import Data.Conduit import qualified Data.Conduit.Binary as CB +import Data.IORef import Data.Typeable import Data.XML.Types - -import Network.Xmpp.Stream -import Network.Xmpp.Types -import System.Log.Logger - -import Control.Concurrent.STM.TMVar - -import Data.IORef -import Crypto.Random.API import Network.TLS import Network.TLS.Extra +import Network.Xmpp.Stream +import Network.Xmpp.Types +import System.Log.Logger (debugM, errorM) mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) , backendRecv = streamReceive con @@ -37,48 +33,54 @@ mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] --- Pushes ", waits for "", performs the TLS handshake, and --- restarts the stream. -startTls :: TMVar Stream -> IO (Either XmppFailure ()) -startTls con = Ex.handle (return . Left . TlsError) +-- | Checks for TLS support and run starttls procedure if applicable +tls :: TMVar Stream -> IO (Either XmppFailure ()) +tls 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 + conf <- gets $ streamConfiguration + sState <- gets streamState + case sState of Plain -> return () Closed -> do - lift $ lift $ errorM "Pontarius.XMPP" "startTls: The stream is closed." + liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is closed." throwError XmppNoStream Secured -> do - lift $ lift $ errorM "Pontarius.XMPP" "startTls: The stream is already secured." + liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is already secured." throwError TlsStreamSecured - con <- lift $ gets streamHandle - when (streamTls features == Nothing) $ do - lift $ lift $ errorM "Pontarius.XMPP" "The server does not support TLS." - throwError TlsNoServerSupport - lift $ pushElement starttlsE - answer <- lift $ pullElement - case answer of - Left e -> return $ Left e - Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right () - Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do - lift $ lift $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." - return . Left $ XmppOtherFailure - (raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend con) - let newHand = StreamHandle { streamSend = catchPush . psh - , streamReceive = read - , streamFlush = contextFlush ctx - , streamClose = bye ctx >> streamClose con - } - lift $ modify ( \x -> x {streamHandle = newHand}) - either (lift . Ex.throwIO) return =<< lift restartStream - modify (\s -> s{streamState = Secured}) - lift $ lift $ debugM "Pontarius.XMPP" "startTls: Stream secured." - return () + features <- lift $ gets streamFeatures + case (tlsBehaviour conf, streamTls features) of + (RequireTls , Just _ ) -> startTls + (RequireTls , Nothing ) -> throwError TlsNoServerSupport + (PreferTls , Just _ ) -> startTls + (PreferTls , Nothing ) -> return () + (PreferPlain , Just True) -> startTls + (PreferPlain , _ ) -> return () + (RefuseTls , Just True) -> throwError XmppOtherFailure + (RefuseTls , _ ) -> return () + where + startTls = do + params <- gets $ tlsParams . streamConfiguration + lift $ pushElement starttlsE + answer <- lift $ pullElement + case answer of + Left e -> return $ Left e + Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> + return $ Right () + Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do + liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." + return . Left $ XmppOtherFailure + hand <- gets streamHandle + (raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend hand) + let newHand = StreamHandle { streamSend = catchPush . psh + , streamReceive = read + , streamFlush = contextFlush ctx + , streamClose = bye ctx >> streamClose hand + } + lift $ modify ( \x -> x {streamHandle = newHand}) + either (lift . Ex.throwIO) return =<< lift restartStream + modify (\s -> s{streamState = Secured}) + return () client params gen backend = do contextNew backend params gen diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 0ec9bfa..d6c8e8c 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1044,6 +1044,8 @@ data StreamConfiguration = -- session bind as defined in the (outdated) -- RFC 3921 specification , establishSession :: Bool + -- | How the client should behave in regards to TLS. + , tlsBehaviour :: TlsBehaviour -- | Settings to be used for TLS negotitation , tlsParams :: TLSParams } @@ -1055,6 +1057,7 @@ instance Default StreamConfiguration where , socketDetails = Nothing , resolvConf = defaultResolvConf , establishSession = False + , tlsBehaviour = PreferTls , tlsParams = defaultParamsClient { pConnectVersion = TLS12 , pAllowedVersions = [TLS12] , pCiphers = ciphersuite_strong @@ -1105,8 +1108,6 @@ data SessionConfiguration = SessionConfiguration , 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 @@ -1118,10 +1119,12 @@ instance Default SessionConfiguration where curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) 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. + | PreferPlain -- ^ Negotitate TLS only if the server requires + -- it | RefuseTls -- ^ Never secure the stream with TLS.