diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 08b263d..5b9e913 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -78,13 +78,13 @@ xmppSasl handlers = withStream $ do cs <- gets streamState case cs of Closed -> return . Left $ XmppNoStream - _ -> do - r <- runErrorT handler + _ -> runErrorT $ do + r <- ErrorT handler case r of - Left ae -> return $ Right $ Just ae - Right a -> do - _ <- runErrorT $ ErrorT restartStream - return $ Right $ Nothing + Just ae -> return $ Just ae + Nothing -> do + _ <- ErrorT restartStream + return Nothing -- | Authenticate to the server using the first matching method and bind a -- resource. diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index bca3ab5..dfb9710 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -127,6 +127,12 @@ digestMd5 :: Text -- ^ Authentication identity (authcid or username) -> Maybe Text -- ^ Authorization identity (authzid) -> Text -- ^ Password -> SaslHandler -digestMd5 authcid authzid password = ( "DIGEST-MD5" - , xmppDigestMd5 authcid authzid password - ) +digestMd5 authcid authzid password = + ( "DIGEST-MD5" + , do + r <- runErrorT $ xmppDigestMd5 authcid authzid password + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index 3e85a50..e2833ce 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -77,4 +77,12 @@ plain :: Text.Text -- ^ authentication ID (username) -> Maybe Text.Text -- ^ authorization ID -> Text.Text -- ^ password -> SaslHandler -plain authcid authzid passwd = ("PLAIN", xmppPlain authcid authzid passwd) +plain authcid authzid passwd = + ( "PLAIN" + , do + r <- runErrorT $ xmppPlain authcid authzid passwd + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index c9905e8..177ce3b 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -164,6 +164,11 @@ scramSha1 :: Text.Text -- ^ username -> Text.Text -- ^ password -> SaslHandler scramSha1 authcid authzid passwd = - ("SCRAM-SHA-1" - , scram (hashToken :: Crypto.SHA1) authcid authzid passwd + ( "SCRAM-SHA-1" + , do + r <- runErrorT $ scram (hashToken :: Crypto.SHA1) authcid authzid passwd + case r of + Left (AuthStreamFailure e) -> return $ Left e + Left e -> return $ Right $ Just e + Right () -> return $ Right Nothing ) diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index e418cd2..e3273da 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -34,4 +34,4 @@ type Pairs = [(ByteString, ByteString)] -- | Tuple defining the SASL Handler's name, and a SASL mechanism computation. -- The SASL mechanism is a stateful @Stream@ computation, which has the -- possibility of resulting in an authentication error. -type SaslHandler = (Text.Text, ErrorT AuthFailure (StateT Stream IO) ()) +type SaslHandler = (Text.Text, StateT Stream IO (Either XmppFailure (Maybe AuthFailure)))