From 6a39cc3f5ef8626f06cd45228a11635969faeece Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 18 Feb 2013 02:02:33 +0100 Subject: [PATCH] Remove SaslM While short, I do believe that `SaslM' type makes the code significantly less understandable. This is at least the case for me. This patch removes it and changes the types to read the full `ErrorT AuthFailure (StateT Stream IO) a' type instead. --- source/Network/Xmpp/Internal.hs | 1 - source/Network/Xmpp/Sasl/Common.hs | 22 ++++++++++--------- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 6 ++--- source/Network/Xmpp/Sasl/Mechanisms/Plain.hs | 2 +- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 8 +++++-- source/Network/Xmpp/Sasl/Types.hs | 10 ++++----- 6 files changed, 26 insertions(+), 23 deletions(-) diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs index 0f42742..be4246d 100644 --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -31,7 +31,6 @@ module Network.Xmpp.Internal , pickleElem , unpickleElem , xpLangTag - , SaslM(..) , SaslHandler(..) , prepCredentials , saslInit diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index c449c71..eea0ce7 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -29,7 +29,9 @@ import Network.Xmpp.Marshal import qualified System.Random as Random ---makeNonce :: SaslM BS.ByteString +import Control.Monad.State.Strict + +--makeNonce :: ErrorT AuthFailure (StateT Stream IO) BS.ByteString makeNonce :: IO BS.ByteString makeNonce = do g <- liftIO Random.newStdGen @@ -106,7 +108,7 @@ xpSaslElement = xpAlt saslSel quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] -saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool +saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Bool saslInit mechanism payload = do r <- lift . pushElement . saslInitE mechanism $ Text.decodeUtf8 . B64.encode <$> payload @@ -115,7 +117,7 @@ saslInit mechanism payload = do Right b -> return b -- | Pull the next element. -pullSaslElement :: SaslM SaslElement +pullSaslElement :: ErrorT AuthFailure (StateT Stream IO) SaslElement pullSaslElement = do r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) case r of @@ -124,7 +126,7 @@ pullSaslElement = do Right (Right r) -> return r -- | Pull the next element, checking that it is a challenge. -pullChallenge :: SaslM (Maybe BS.ByteString) +pullChallenge :: ErrorT AuthFailure (StateT Stream IO) (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement case e of @@ -135,12 +137,12 @@ pullChallenge = do _ -> throwError AuthChallengeFailure -- | Extract value from Just, failing with AuthChallengeFailure on Nothing. -saslFromJust :: Maybe a -> SaslM a +saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT Stream IO) a saslFromJust Nothing = throwError $ AuthChallengeFailure saslFromJust (Just d) = return d -- | Pull the next element and check that it is success. -pullSuccess :: SaslM (Maybe Text.Text) +pullSuccess :: ErrorT AuthFailure (StateT Stream IO) (Maybe Text.Text) pullSuccess = do e <- pullSaslElement case e of @@ -149,7 +151,7 @@ pullSuccess = do -- | Pull the next element. When it's success, return it's payload. -- If it's a challenge, send an empty response and pull success. -pullFinalMessage :: SaslM (Maybe BS.ByteString) +pullFinalMessage :: ErrorT AuthFailure (StateT Stream IO) (Maybe BS.ByteString) pullFinalMessage = do challenge2 <- pullSaslElement case challenge2 of @@ -165,13 +167,13 @@ pullFinalMessage = do Right x -> return $ Just x -- | Extract p=q pairs from a challenge. -toPairs :: BS.ByteString -> SaslM Pairs +toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Pairs toPairs ctext = case pairs ctext of Left _e -> throwError AuthChallengeFailure Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. -respond :: Maybe BS.ByteString -> SaslM Bool +respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Bool respond m = do r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m case r of @@ -182,7 +184,7 @@ respond m = do -- | Run the appropriate stringprep profiles on the credentials. -- May fail with 'AuthStringPrepFailure' prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text - -> SaslM (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 Just creds -> return creds diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 8d83d40..bca3ab5 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -42,15 +42,15 @@ import Network.Xmpp.Sasl.Types xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> Maybe Text -- ^ Authorization identity (authcid) -> Text -- ^ Password (authzid) - -> SaslM () + -> ErrorT AuthFailure (StateT Stream IO) () xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password hn <- gets streamHostname xmppDigestMd5' (fromJust hn) ac az pw where - xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () + xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT Stream IO) () xmppDigestMd5' hostname authcid authzid password = do - -- Push element and receive the challenge (in SaslM). + -- Push element and receive the challenge. _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? pairs <- toPairs =<< saslFromJust =<< pullChallenge cnonce <- liftIO $ makeNonce diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index caea0ec..3e85a50 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -50,7 +50,7 @@ import Network.Xmpp.Sasl.Types xmppPlain :: Text.Text -- ^ Password -> Maybe Text.Text -- ^ Authorization identity (authzid) -> Text.Text -- ^ Authentication identity (authcid) - -> SaslM () + -> ErrorT AuthFailure (StateT Stream IO) () xmppPlain authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index e9cebc7..4262c63 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -29,6 +29,10 @@ import Data.Word(Word8) import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types + + +import Control.Monad.State.Strict -- | A nicer name for undefined, for use as a dummy token to determin -- the hash function to use @@ -45,7 +49,7 @@ scram :: (Crypto.Hash ctx hash) -> Text.Text -- ^ Authentication ID (user name) -> Maybe Text.Text -- ^ Authorization ID -> Text.Text -- ^ Password - -> SaslM () + -> ErrorT AuthFailure (StateT Stream IO) () scram hashToken authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password scramhelper hashToken ac az pw @@ -94,7 +98,7 @@ scram hashToken authcid authzid password = do fromPairs :: Pairs -> BS.ByteString - -> SaslM (BS.ByteString, BS.ByteString, Integer) + -> ErrorT AuthFailure (StateT Stream IO) (BS.ByteString, BS.ByteString, Integer) fromPairs pairs cnonce | Just nonce <- lookup "r" pairs , cnonce `BS.isPrefixOf` nonce , Just salt' <- lookup "s" pairs diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index 43879c7..c341585 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -27,11 +27,9 @@ instance Error AuthFailure where data SaslElement = SaslSuccess (Maybe Text.Text) | SaslChallenge (Maybe Text.Text) --- | SASL mechanism Stream computation, with the possibility of throwing --- an authentication error. -type SaslM a = ErrorT AuthFailure (StateT Stream IO) a - type Pairs = [(ByteString, ByteString)] --- | Tuple defining the SASL Handler's name, and a SASL mechanism computation -type SaslHandler = (Text.Text, SaslM ()) +-- | 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) ())