From 7b8092343331bfceee7f19b258fb1579ecfa305c Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 4 Jun 2012 18:45:54 +0200 Subject: [PATCH] refactor digestMd5 to move common functionality to module Common --- source/Network/Xmpp/Sasl/Common.hs | 81 ++++++++++++++++++++++----- source/Network/Xmpp/Sasl/DigestMD5.hs | 44 ++++++--------- source/Network/Xmpp/Sasl/Types.hs | 15 +++-- 3 files changed, 93 insertions(+), 47 deletions(-) diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 75e2b3e..84ee393 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -9,13 +9,20 @@ import Control.Monad.Error import qualified Data.Attoparsec.ByteString.Char8 as AP import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 import Data.Maybe (fromMaybe) import Data.Maybe (maybeToList) import Data.Text +import qualified Data.Text.Encoding as Text import Data.XML.Pickle import Data.XML.Types +import Network.Xmpp.Monad import Network.Xmpp.Pickle +import Network.Xmpp.Sasl.Types + +data SaslElement = SaslSuccess + | SaslChallenge (Maybe Text) -- The element, with an -- optional round-trip value. @@ -26,22 +33,18 @@ saslInitE mechanism rt = (maybeToList $ NodeContent . ContentText <$> rt) -- SASL response with text payload. -saslResponseE :: Text -> Element +saslResponseE :: Maybe Text -> Element saslResponseE resp = Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] - [NodeContent $ ContentText resp] + (maybeToList $ NodeContent . ContentText <$> resp) --- SASL response without payload. -saslResponse2E :: Element -saslResponse2E = - Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" - [] - [] +xpSuccess :: PU [Node] () +xpSuccess = xpElemBlank "{urn:ietf:params:xml:ns:xmpp-sasl}success" -- Parses the incoming SASL data to a mapped list of pairs. -toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] -toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do +pairs :: BS.ByteString -> Either String Pairs +pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do AP.skipSpace name <- AP.takeWhile1 (/= '=') _ <- AP.char '=' @@ -51,8 +54,8 @@ toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do return (name, content) -- Failure element pickler. -failurePickle :: PU [Node] SaslFailure -failurePickle = xpWrap +xpFailure :: PU [Node] SaslFailure +xpFailure = xpWrap (\(txt, (failure, _, _)) -> SaslFailure failure txt) (\(SaslFailure failure txt) -> (txt,(failure,(),()))) (xpElemNodes @@ -68,6 +71,54 @@ failurePickle = xpWrap (xpUnit) (xpUnit)))) -- Challenge element pickler. -challengePickle :: PU [Node] Text -challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" - (xpIsolate $ xpContent xpId) \ No newline at end of file +xpChallenge :: PU [Node] (Maybe Text) +xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" + (xpOption $ xpContent xpId) + +xpSaslElement = xpAlt saslSel + [ xpWrap (const SaslSuccess) (const ()) xpSuccess + , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge + ] + where + saslSel SaslSuccess = 0 + saslSel (SaslChallenge _) = 1 + +quote :: BS.ByteString -> BS.ByteString +quote x = BS.concat ["\"",x,"\""] + +saslInit :: Text -> Maybe Text -> SaslM Bool +saslInit mechanism payload = lift . pushElement $ saslInitE mechanism payload + +pullSaslElement :: SaslM SaslElement +pullSaslElement = do + el <- lift $ pullPickle (xpEither xpFailure xpSaslElement) + case el of + Left e ->throwError $ AuthSaslFailure e + Right r -> return r + +pullChallenge :: SaslM (Maybe Text) +pullChallenge = do + e <- pullSaslElement + case e of + SaslChallenge sc -> return sc + _ -> throwError AuthChallengeError + +saslFromJust :: Maybe a -> SaslM a +saslFromJust Nothing = throwError $ AuthChallengeError +saslFromJust (Just d) = return d + +pullSuccess :: SaslM () +pullSuccess = do + e <- pullSaslElement + case e of + SaslSuccess -> return () + _ -> throwError $ AuthXmlError + +toPairs :: Text -> SaslM Pairs +toPairs ctext = case pairs <=< B64.decode . Text.encodeUtf8 $ ctext of + Left _e -> throwError AuthChallengeError + Right r -> return r + +respond :: Maybe Text -> SaslM Bool +respond = lift . pushElement . saslResponseE + diff --git a/source/Network/Xmpp/Sasl/DigestMD5.hs b/source/Network/Xmpp/Sasl/DigestMD5.hs index 1188758..16361d4 100644 --- a/source/Network/Xmpp/Sasl/DigestMD5.hs +++ b/source/Network/Xmpp/Sasl/DigestMD5.hs @@ -36,9 +36,11 @@ import Network.Xmpp.Pickle import qualified System.Random as Random -import Network.Xmpp.Sasl.Sasl +import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types + + xmppDigestMD5 :: Maybe Text -- Authorization identity (authzid) -> Text -- Authentication identity (authzid) -> Text -- Password (authzid) @@ -47,38 +49,26 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do realm <- gets sHostname case realm of Just realm' -> do - ErrorT $ xmppDigestMD5' realm' + xmppDigestMD5' realm' -- TODO: Save authzid modify (\s -> s{sUsername = Just authcid}) Nothing -> throwError AuthConnectionError where xmppDigestMD5' :: Text -- ^ SASL realm - -> XmppConMonad (Either AuthError ()) - xmppDigestMD5' realm = runErrorT $ do - -- Push element and receive the challenge (in XmppConMonad). - _ <- lift . pushElement $ saslInitE "DIGEST-MD5" Nothing -- TODO: Check boolean? - challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> - pullPickle challengePickle - challenge <- case challenge' of - Left _e -> throwError AuthChallengeError - Right r -> return r - pairs <- case toPairs challenge of - Left _ -> throwError AuthChallengeError - Right p -> return p + -> SaslM () + xmppDigestMD5' realm = do + -- Push element and receive the challenge (in SaslM). + _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? + pairs <- toPairs =<< saslFromJust =<< pullChallenge g <- liftIO Random.newStdGen - _ <- lift . pushElement . -- TODO: Check boolean? - saslResponseE $ createResponse g realm pairs - challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) + _b <- respond . Just $ createResponse g realm pairs + challenge2 <- pullSaslElement case challenge2 of - Left _x -> throwError AuthXmlError - Right _ -> return () - lift $ pushElement saslResponse2E - e <- lift pullElement - case e of - Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> - return () - _ -> throwError AuthXmlError -- TODO: investigate - -- The SASL authentication has succeeded; the stream is restarted. + SaslSuccess -> return () + SaslChallenge Nothing -> do + _b <- respond Nothing + pullSuccess + _ -> throwError AuthChallengeError _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream return () -- Produce the response to the challenge. @@ -121,8 +111,6 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do , ["charset" , "utf-8" ] ] in Text.decodeUtf8 $ B64.encode response - quote :: BS8.ByteString -> BS8.ByteString - quote x = BS.concat ["\"",x,"\""] toWord8 :: Int -> Word8 toWord8 x = fromIntegral x :: Word8 hash :: [BS8.ByteString] -> BS8.ByteString diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index f870c93..c7cf184 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -1,8 +1,10 @@ module Network.Xmpp.Sasl.Types where -import Control.Monad.Error -import Data.Text -import Network.Xmpp.Types +import Control.Monad.Error +import Control.Monad.State.Strict +import Data.Text +import Network.Xmpp.Types +import Data.ByteString(ByteString) data AuthError = AuthXmlError | AuthMechanismError [Text] -- ^ Wraps mechanisms offered @@ -10,7 +12,12 @@ data AuthError = AuthXmlError | AuthStreamError StreamError -- ^ Stream error on stream restart | AuthConnectionError -- ^ No host name set in state | AuthError -- General instance used for the Error instance + | AuthSaslFailure SaslFailure -- ^ defined SASL error condition deriving Show instance Error AuthError where - noMsg = AuthError \ No newline at end of file + noMsg = AuthError + +type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a + +type Pairs = [(ByteString, ByteString)] \ No newline at end of file