From c7c4a292195e12e16da93dbecb9a884acb765001 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 23 Mar 2013 18:27:19 +0100 Subject: [PATCH] Fix loggin in Network.Xmpp.Tls and minor cleanups --- source/Network/Xmpp/Concurrent.hs | 1 - source/Network/Xmpp/Sasl/Common.hs | 12 ++++----- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 6 ++--- source/Network/Xmpp/Tls.hs | 27 ++++++++++---------- 4 files changed, 22 insertions(+), 24 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index eaa5943..6896473 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -42,7 +42,6 @@ import Network.Xmpp.Tls import Network.Xmpp.Types import Network.Xmpp.Utilities - runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO () runHandlers _ [] _ = return () runHandlers outC (h:hands) sta = do diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 47f8744..fb15668 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -186,12 +186,12 @@ prepCredentials authcid authzid password = case credentials of Just creds -> return creds where credentials = do - ac <- normalizeUsername authcid - az <- case authzid of - Nothing -> Just Nothing - Just az' -> Just <$> normalizeUsername az' - pw <- normalizePassword password - return (ac, az, pw) + ac <- normalizeUsername authcid + az <- case authzid of + Nothing -> Just Nothing + Just az' -> Just <$> normalizeUsername az' + pw <- normalizePassword password + return (ac, az, pw) -- | Bit-wise xor of byte strings xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index c7b2572..d7a5515 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -72,9 +72,9 @@ scram hToken authcid authzid password = do gs2Header :: BS.ByteString gs2Header = merge $ [ gs2CbindFlag - , maybe "" id authzid'' - , "" - ] + , maybe "" id authzid'' + , "" + ] -- cbindData :: BS.ByteString -- cbindData = "" -- we don't support channel binding yet diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index c4e70b4..3027b85 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -18,7 +18,7 @@ import Data.XML.Types import Network.TLS import Network.Xmpp.Stream import Network.Xmpp.Types -import System.Log.Logger (debugM, errorM) +import System.Log.Logger (debugM, errorM, infoM) mkBackend :: StreamHandle -> Backend mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) @@ -51,27 +51,29 @@ tls con = Ex.handle (return . Left . TlsError) case sState of Plain -> return () Closed -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is closed." + liftIO $ errorM "Pontarius.Xmpp" "startTls: The stream is closed." throwError XmppNoStream Secured -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is already secured." + liftIO $ errorM "Pontarius.Xmpp" "startTls: The stream is already secured." throwError TlsStreamSecured features <- lift $ gets streamFeatures case (tlsBehaviour conf, streamTls features) of (RequireTls , Just _ ) -> startTls (RequireTls , Nothing ) -> throwError TlsNoServerSupport (PreferTls , Just _ ) -> startTls - (PreferTls , Nothing ) -> return () + (PreferTls , Nothing ) -> skipTls (PreferPlain , Just True) -> startTls - (PreferPlain , _ ) -> return () + (PreferPlain , _ ) -> skipTls (RefuseTls , Just True) -> throwError XmppOtherFailure - (RefuseTls , _ ) -> return () + (RefuseTls , _ ) -> skipTls where + skipTls = liftIO $ infoM "Pontarius.Xmpp" "Skipping TLS negotiation" startTls = do + liftIO $ infoM "Pontarius.Xmpp" "Running StartTLS" params <- gets $ tlsParams . streamConfiguration sent <- ErrorT $ pushElement starttlsE unless sent $ do - liftIO $ errorM "Pontarius.XMPP" "startTls: Could not sent stanza." + liftIO $ errorM "Pontarius.Xmpp" "startTls: Could not sent stanza." throwError XmppOtherFailure answer <- lift $ pullElement case answer of @@ -79,10 +81,10 @@ tls con = Ex.handle (return . Left . TlsError) Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return () Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." + liftIO $ errorM "Pontarius.Xmpp" "startTls: TLS initiation failed." throwError XmppOtherFailure Right r -> - liftIO $ errorM "Pontarius.XMPP" $ + liftIO $ errorM "Pontarius.Xmpp" $ "startTls: Unexpected element: " ++ show r hand <- gets streamHandle (_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand) @@ -92,6 +94,7 @@ tls con = Ex.handle (return . Left . TlsError) , streamClose = bye ctx >> streamClose hand } lift $ modify ( \x -> x {streamHandle = newHand}) + liftIO $ infoM "Pontarius.Xmpp" "Stream Secured." either (lift . Ex.throwIO) return =<< lift restartStream modify (\s -> s{streamConnectionState = Secured}) return () @@ -127,15 +130,11 @@ tlsinit params backend = do Nothing -> return () Just x -> do sendData con (BL.fromChunks [x]) - liftIO $ debugM "Pontarius.Xmpp.TLS" - ("out :" ++ BSC8.unpack x) snk readWithBuffer <- liftIO $ mkReadBuffer (recvData con) return ( src , snk - , \s -> do - liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s) - sendData con $ BL.fromChunks [s] + , \s -> sendData con $ BL.fromChunks [s] , liftIO . readWithBuffer , con )