From 655aeb5b6b050d05d16e1027b46f928c3bc7b9fa Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Tue, 19 Feb 2013 00:08:04 +0100 Subject: [PATCH] Clean up and additionally document AuthFailure (and XmppFailure) types As mentioned in a previous patch, the `AuthFailure' type signals a (non-fatal) SASL error condition. This is now reflected in the documentation. I went through the different constructors for the type, looking at how they were produced (thrown) and whether or not that information were useful for the application using Pontarius XMPP. To begin, I conclude that `AuthStreamFailure' is only used internally. It will probably be removed when the internal type signatures of the Sasl package are changed to conform with the rest of the `Error' computations of Pontarius XMPP. `AuthFailure' is not thrown as far as I can see, but is only used for the Error instance. `AuthNoAcceptableMechanism' is thrown by `xmppSasl' when none of the mechanisms offered by the server is specified as acceptable by the client. It wraps the mechanisms offered. I consider this information useful for client developers, and will therefor keep this constructor. `AuthSaslFailure' wraps a `SaslFailure' (from Types.hs) and is only thrown when `pullSaslElement' unpickles a SASL failure. This, together with `AuthNoAcceptableMechanism' above, could be considered the `normal' ways of which SASL might be failing. `AuthStringPrepFailure' is thrown if `prepCredentials' fails to stringprep-verify the credentials. This might be interesting for the client developer. As I think that `AuthIllegalCredentials' is more understandable, I have changed the name to that. `AuthNoStream' is thrown by `xmppSasl' when the stream state is `Closed'. This is the result of a client program error/bug. This patch removes this constructor and modifies the behaviour of xmppSasl to throw an `XmppFailure' instead. `AuthChallengeFailure' is thrown if `fromPairs' fails (in Scram.hs), if a challenge element could not be pulled (in Common.hs), by `saslFromJust' if a `Nothing' value is encountered (in Common.hs), in `pullFinalMessage' (`decode') if the success payload could not be decoded (in Common.hs), or if `toPairs' (in Common.hs) can not extract the pairs. Furthermore, `AuthServerAuthFailure' is thrown if there is no `v' value in the final message of the SCRAM handler. Finally, `AuthXmlFailure' is thrown when `pullSuccess' find something other than a success element (and, I'm guessing, a `SaslFailure' element). This can only happen if there is a bug in Pontarius XMPP or the server. The way I see it, all these failures are abnormal and are of no interest from the client application itself. I suggest that these events are logged instead, and that we signal any of these conditions with a new `AuthOtherFailure' constructor. I suggest that we remove the `AuthFailure' constructor, and use the `AuthOtherFailure' for the `Error' instance. The `AuthFailure' type and all its constructors are now documented. I also made some minor documentation enhancements to the `XmppFailure' type. --- source/Network/Xmpp.hs | 9 +++---- source/Network/Xmpp/Sasl.hs | 2 +- source/Network/Xmpp/Sasl/Common.hs | 14 +++++----- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 4 +-- source/Network/Xmpp/Sasl/Types.hs | 28 +++++++++++--------- source/Network/Xmpp/Types.hs | 15 +++++++---- 6 files changed, 38 insertions(+), 34 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index f545cba..cd1daf0 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -142,13 +142,10 @@ module Network.Xmpp , XmppFailure(..) , StreamErrorInfo(..) , StreamErrorCondition(..) - , AuthFailure( AuthXmlFailure -- Does not export AuthStreamFailure - , AuthNoAcceptableMechanism - , AuthChallengeFailure - , AuthNoStream - , AuthFailure + , AuthFailure( AuthNoAcceptableMechanism , AuthSaslFailure - , AuthStringPrepFailure ) + , AuthIllegalCredentials + , AuthOtherFailure ) ) where diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index fff8bb2..4d8a952 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -76,7 +76,7 @@ xmppSasl handlers stream = (flip withStream stream) $ do (_name, handler):_ -> do cs <- gets streamState case cs of - Closed -> return . Right $ Just AuthNoStream + Closed -> return . Left $ XmppNoStream _ -> lift $ handler stream -- | Authenticate to the server using the first matching method and bind a diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index eea0ce7..6a34aec 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -134,11 +134,11 @@ pullChallenge = do SaslChallenge (Just scb64) | Right sc <- B64.decode . Text.encodeUtf8 $ scb64 -> return $ Just sc - _ -> throwError AuthChallengeFailure + _ -> throwError AuthOtherFailure -- TODO: Log --- | Extract value from Just, failing with AuthChallengeFailure on Nothing. +-- | Extract value from Just, failing with AuthOtherFailure on Nothing. saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT Stream IO) a -saslFromJust Nothing = throwError $ AuthChallengeFailure +saslFromJust Nothing = throwError $ AuthOtherFailure -- TODO: Log saslFromJust (Just d) = return d -- | Pull the next element and check that it is success. @@ -147,7 +147,7 @@ pullSuccess = do e <- pullSaslElement case e of SaslSuccess x -> return x - _ -> throwError $ AuthXmlFailure + _ -> throwError $ AuthOtherFailure -- TODO: Log -- | Pull the next element. When it's success, return it's payload. -- If it's a challenge, send an empty response and pull success. @@ -163,13 +163,13 @@ pullFinalMessage = do where decode Nothing = return Nothing decode (Just d) = case B64.decode $ Text.encodeUtf8 d of - Left _e -> throwError $ AuthChallengeFailure + Left _e -> throwError $ AuthOtherFailure -- TODO: Log Right x -> return $ Just x -- | Extract p=q pairs from a challenge. toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Pairs toPairs ctext = case pairs ctext of - Left _e -> throwError AuthChallengeFailure + Left _e -> throwError AuthOtherFailure -- TODO: Log Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. @@ -186,7 +186,7 @@ respond m = do prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text -> ErrorT AuthFailure (StateT Stream IO) (Text.Text, Maybe Text.Text, Text.Text) prepCredentials authcid authzid password = case credentials of - Nothing -> throwError $ AuthStringPrepFailure + Nothing -> throwError $ AuthIllegalCredentials Just creds -> return creds where credentials = do diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 809a95b..618ffb9 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -63,7 +63,7 @@ scram hashToken authcid authzid password = do let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce respond $ Just cfm finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage - unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthFailure + unless (lookup "v" finalPairs == Just v) $ throwError AuthOtherFailure -- TODO: Log return () where -- We need to jump through some hoops to get a polymorphic solution @@ -106,7 +106,7 @@ scram hashToken authcid authzid password = do , Just ic <- lookup "i" pairs , [(i,"")] <- reads $ BS8.unpack ic = return (nonce, salt, i) - fromPairs _ _ = throwError $ AuthChallengeFailure + fromPairs _ _ = throwError $ AuthOtherFailure -- TODO: Log cFinalMessageAndVerifier :: BS.ByteString -> BS.ByteString diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index 8aea51e..fbdd408 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -8,22 +8,24 @@ import qualified Data.Text as Text import Network.Xmpp.Types import Control.Concurrent.STM -data AuthFailure = AuthXmlFailure - | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms - -- offered - | AuthChallengeFailure - | AuthServerAuthFailure -- ^ The server failed to authenticate - -- itself - | AuthStreamFailure XmppFailure -- ^ Stream error on stream restart - -- TODO: Rename AuthConnectionFailure? - | AuthNoStream - | AuthFailure -- General instance used for the Error instance - | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition - | AuthStringPrepFailure -- ^ StringPrep failed +-- | Signals a (non-fatal) SASL authentication error condition. +data AuthFailure = -- | No mechanism offered by the server was matched + -- by the provided acceptable mechanisms; wraps the + -- mechanisms offered by the server + AuthNoAcceptableMechanism [Text.Text] + | AuthStreamFailure XmppFailure -- TODO: Remove + -- | A SASL failure element was encountered + | AuthSaslFailure SaslFailure + -- | The credentials provided did not conform to + -- the SASLprep Stringprep profile + | AuthIllegalCredentials + -- | Other failure; more information is available + -- in the log + | AuthOtherFailure deriving Show instance Error AuthFailure where - noMsg = AuthFailure + noMsg = AuthOtherFailure data SaslElement = SaslSuccess (Maybe Text.Text) | SaslChallenge (Maybe Text.Text) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 5fd4f41..e2eae15 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -634,7 +634,7 @@ data StreamErrorInfo = StreamErrorInfo } deriving (Show, Eq) -- | Signals an XMPP stream error or another unpredicted stream-related --- situation. +-- situation. This error is fatal, and closes the XMPP stream. data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream -- element has been -- encountered. @@ -649,14 +649,19 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream -- constructor wraps the -- elements collected so -- far. - | TlsError TLS.TLSError - | TlsNoServerSupport - | XmppNoStream + | TlsError TLS.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 + -- stream were performed when the + -- 'StreamState' was 'Closed' | TlsStreamSecured -- ^ Connection already secured | XmppOtherFailure -- ^ Undefined condition. More -- information should be available -- in the log. - | XmppIOException IOException + | XmppIOException IOException -- ^ An 'IOException' + -- occurred deriving (Show, Eq, Typeable) instance Exception XmppFailure