From 97b08fa27701daa553bda6a3b7fd969dcee861f5 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 29 May 2012 17:11:50 +0200 Subject: [PATCH 1/6] rename more occurences of DIGEST_MD5 and PLAIN to DigestMD5 and Plain respectively --- source/Network/Xmpp.hs | 2 +- source/Network/Xmpp/Sasl.hs | 16 ++++++++-------- source/Network/Xmpp/Types.hs | 16 ++++++++-------- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 83c8947..3c9a233 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -165,7 +165,7 @@ auth :: Text.Text -- ^ The username -- assign one -> XmppConMonad (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do - ErrorT $ xmppSASL [DIGEST_MD5Credentials Nothing username passwd] + ErrorT $ xmppSasl [DigestMD5Credentials Nothing username passwd] res <- lift $ xmppBind resource lift $ xmppStartSession return res diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 569d2f3..14a77ec 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -39,29 +39,29 @@ import Network.Xmpp.Sasl.Types -- XmppConMonad state with non-password credentials and restarts the stream upon -- success. This computation wraps an ErrorT computation, which means that -- catchError can be used to catch any errors. -xmppSASL :: [SASLCredentials] -- ^ Acceptable authentication mechanisms and +xmppSasl :: [SaslCredentials] -- ^ Acceptable authentication mechanisms and -- their corresponding credentials -> XmppConMonad (Either AuthError ()) -xmppSASL creds = runErrorT $ do +xmppSasl creds = runErrorT $ do -- Chooses the first mechanism that is acceptable by both the client and the -- server. mechanisms <- gets $ saslMechanisms . sFeatures let cred = L.find (\cred -> credsToName cred `elem` mechanisms) creds unless (isJust cred) (throwError $ AuthMechanismError mechanisms) case fromJust cred of - DIGEST_MD5Credentials authzid authcid passwd -> ErrorT $ xmppDigestMD5 + DigestMD5Credentials authzid authcid passwd -> ErrorT $ xmppDigestMD5 authzid authcid passwd - PLAINCredentials authzid authcid passwd -> ErrorT $ xmppPLAIN + PlainCredentials authzid authcid passwd -> ErrorT $ xmppPLAIN authzid authcid passwd - _ -> error "xmppSASL: Mechanism not caught" + _ -> error "xmppSasl: Mechanism not caught" where -- Converts the credentials to the appropriate mechanism name, corresponding to -- the XMPP mechanism attribute. - credsToName :: SASLCredentials -> Text - credsToName (DIGEST_MD5Credentials _ _ _) = "DIGEST-MD5" - credsToName (PLAINCredentials _ _ _) = "PLAIN" + credsToName :: SaslCredentials -> Text + credsToName (DigestMD5Credentials _ _ _) = "DIGEST-MD5" + credsToName (PlainCredentials _ _ _) = "PLAIN" credsToName c = error $ "credsToName failed for " ++ (show c) \ No newline at end of file diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 4be0af5..f7d278e 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -22,8 +22,8 @@ module Network.Xmpp.Types , PresenceType(..) , SaslError(..) , SaslFailure(..) - , SASLMechanism (..) - , SASLCredentials (..) + , SaslMechanism (..) + , SaslCredentials (..) , ServerFeatures(..) , Stanza(..) , StanzaError(..) @@ -402,18 +402,18 @@ instance Read StanzaErrorCondition where -- OTHER STUFF -- ============================================================================= -data SASLCredentials = DIGEST_MD5Credentials (Maybe Text) Text Text - | PLAINCredentials (Maybe Text) Text Text +data SaslCredentials = DigestMD5Credentials (Maybe Text) Text Text + | PlainCredentials (Maybe Text) Text Text -instance Show SASLCredentials where - show (DIGEST_MD5Credentials authzid authcid _) = "DIGEST_MD5Credentials " ++ +instance Show SaslCredentials where + show (DigestMD5Credentials authzid authcid _) = "DIGEST_MD5Credentials " ++ (Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++ " (password hidden)" - show (PLAINCredentials authzid authcid _) = "PLAINCredentials " ++ + show (PlainCredentials authzid authcid _) = "PLAINCredentials " ++ (Text.unpack $ fromMaybe "" authzid) ++ " " ++ (Text.unpack authcid) ++ " (password hidden)" -data SASLMechanism = DIGEST_MD5 deriving Show +data SaslMechanism = DigestMD5 deriving Show data SaslFailure = SaslFailure { saslFailureCondition :: SaslError , saslFailureText :: Maybe ( Maybe LangTag From 5b536428a92a1a093dfdd1a14fc3432473ebf3bc Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 4 Jun 2012 15:13:20 +0200 Subject: [PATCH 2/6] Change more all-caps names to camel case rename Sasl.Sasl to Sasl.Common --- source/Network/Xmpp/Sasl.hs | 2 +- source/Network/Xmpp/Sasl/{Sasl.hs => Common.hs} | 17 +++++++++++------ source/Network/Xmpp/Sasl/DigestMD5.hs | 6 +++--- source/Network/Xmpp/Sasl/Plain.hs | 4 ++-- 4 files changed, 17 insertions(+), 12 deletions(-) rename source/Network/Xmpp/Sasl/{Sasl.hs => Common.hs} (87%) diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 14a77ec..34c504d 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -53,7 +53,7 @@ xmppSasl creds = runErrorT $ do authzid authcid passwd - PlainCredentials authzid authcid passwd -> ErrorT $ xmppPLAIN + PlainCredentials authzid authcid passwd -> ErrorT $ xmppPlain authzid authcid passwd diff --git a/source/Network/Xmpp/Sasl/Sasl.hs b/source/Network/Xmpp/Sasl/Common.hs similarity index 87% rename from source/Network/Xmpp/Sasl/Sasl.hs rename to source/Network/Xmpp/Sasl/Common.hs index e72d6e4..75e2b3e 100644 --- a/source/Network/Xmpp/Sasl/Sasl.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -1,16 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Sasl where +module Network.Xmpp.Sasl.Common where -import Network.Xmpp.Types +import Network.Xmpp.Types +import Control.Applicative ((<$>)) import Control.Monad.Error -import Data.Text + import qualified Data.Attoparsec.ByteString.Char8 as AP +import qualified Data.ByteString as BS +import Data.Maybe (fromMaybe) +import Data.Maybe (maybeToList) +import Data.Text import Data.XML.Pickle import Data.XML.Types -import qualified Data.ByteString as BS -import Data.Maybe (fromMaybe) import Network.Xmpp.Pickle @@ -20,7 +23,7 @@ saslInitE :: Text -> Maybe Text -> Element saslInitE mechanism rt = Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" [("mechanism", [ContentText mechanism])] - [NodeContent $ ContentText $ fromMaybe "" rt] + (maybeToList $ NodeContent . ContentText <$> rt) -- SASL response with text payload. saslResponseE :: Text -> Element @@ -28,12 +31,14 @@ saslResponseE resp = Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] [NodeContent $ ContentText resp] + -- SASL response without payload. saslResponse2E :: Element saslResponse2E = Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] [] + -- 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 diff --git a/source/Network/Xmpp/Sasl/DigestMD5.hs b/source/Network/Xmpp/Sasl/DigestMD5.hs index 1872ded..1188758 100644 --- a/source/Network/Xmpp/Sasl/DigestMD5.hs +++ b/source/Network/Xmpp/Sasl/DigestMD5.hs @@ -47,14 +47,14 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do realm <- gets sHostname case realm of Just realm' -> do - ErrorT $ xmppDIGEST_MD5' realm' + ErrorT $ xmppDigestMD5' realm' -- TODO: Save authzid modify (\s -> s{sUsername = Just authcid}) Nothing -> throwError AuthConnectionError where - xmppDIGEST_MD5' :: Text -- ^ SASL realm + xmppDigestMD5' :: Text -- ^ SASL realm -> XmppConMonad (Either AuthError ()) - xmppDIGEST_MD5' realm = runErrorT $ do + 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 <$> diff --git a/source/Network/Xmpp/Sasl/Plain.hs b/source/Network/Xmpp/Sasl/Plain.hs index e265230..ad8a032 100644 --- a/source/Network/Xmpp/Sasl/Plain.hs +++ b/source/Network/Xmpp/Sasl/Plain.hs @@ -45,11 +45,11 @@ import qualified Data.Text as T import Network.Xmpp.Sasl.Sasl import Network.Xmpp.Sasl.Types -xmppPLAIN :: Maybe T.Text +xmppPlain :: Maybe T.Text -> T.Text -> T.Text -> XmppConMonad (Either AuthError ()) -xmppPLAIN authzid authcid passwd = runErrorT $ do +xmppPlain authzid authcid passwd = runErrorT $ do _ <- lift . pushElement $ saslInitE "PLAIN" $ -- TODO: Check boolean? Just $ Text.decodeUtf8 $ B64.encode $ Text.encodeUtf8 $ plainMessage authzid authcid passwd lift $ pushElement saslResponse2E From 7b8092343331bfceee7f19b258fb1579ecfa305c Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 4 Jun 2012 18:45:54 +0200 Subject: [PATCH 3/6] 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 From cfb3597feb857af8b9c7ebd1232c207c4a8eefd8 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 9 Jun 2012 00:19:37 +0200 Subject: [PATCH 4/6] add scram add sAuthzid to XmppConnection add sAuthzid to XmppConnection more work on sasl infrastructure move more stuff from DigestMd5 to Common more work on sasl infrastructure --- pontarius.cabal | 2 + source/Network/Xmpp.hs | 4 +- source/Network/Xmpp/Monad.hs | 5 +- source/Network/Xmpp/Sasl.hs | 50 +++++---- source/Network/Xmpp/Sasl/Common.hs | 70 ++++++++---- source/Network/Xmpp/Sasl/DigestMD5.hs | 46 +++----- source/Network/Xmpp/Sasl/Plain.hs | 52 +++++---- source/Network/Xmpp/Sasl/Scram.hs | 152 ++++++++++++++++++++++++++ source/Network/Xmpp/Sasl/Types.hs | 20 ++-- source/Network/Xmpp/Types.hs | 1 + tests/Tests.hs | 10 +- 11 files changed, 300 insertions(+), 112 deletions(-) create mode 100644 source/Network/Xmpp/Sasl/Scram.hs diff --git a/pontarius.cabal b/pontarius.cabal index 92d4224..49a8090 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -37,6 +37,7 @@ Library , binary -any , attoparsec -any , crypto-api -any + , cryptohash -any , text -any , bytestring -any , transformers -any @@ -62,6 +63,7 @@ Library , Network.Xmpp.Sasl , Network.Xmpp.Sasl.Plain , Network.Xmpp.Sasl.DigestMD5 + , Network.Xmpp.Sasl.Scram , Network.Xmpp.Sasl.Types , Network.Xmpp.Session , Network.Xmpp.Stream diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 3c9a233..fae301c 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -145,6 +145,8 @@ import Network.Xmpp.Message import Network.Xmpp.Monad import Network.Xmpp.Presence import Network.Xmpp.Sasl +import Network.Xmpp.Sasl.Scram +import Network.Xmpp.Sasl.Plain import Network.Xmpp.Sasl.Types import Network.Xmpp.Session import Network.Xmpp.Stream @@ -165,7 +167,7 @@ auth :: Text.Text -- ^ The username -- assign one -> XmppConMonad (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do - ErrorT $ xmppSasl [DigestMD5Credentials Nothing username passwd] + ErrorT $ xmppSasl username Nothing [scramSha1 $ return passwd] res <- lift $ xmppBind resource lift $ xmppStartSession return res diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs index 14670a2..9843eb7 100644 --- a/source/Network/Xmpp/Monad.hs +++ b/source/Network/Xmpp/Monad.hs @@ -99,6 +99,7 @@ xmppNoConnection = XmppConnection , sFeatures = SF Nothing [] [] , sConnectionState = XmppConnectionClosed , sHostname = Nothing + , sAuthzid = Nothing , sUsername = Nothing , sResource = Nothing , sCloseConnection = return () @@ -111,7 +112,6 @@ xmppNoConnection = XmppConnection -- updates the XmppConMonad XmppConnection state. xmppRawConnect :: HostName -> Text -> XmppConMonad () xmppRawConnect host hostname = do - uname <- gets sUsername con <- liftIO $ do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering @@ -126,7 +126,8 @@ xmppRawConnect host hostname = do (SF Nothing [] []) XmppConnectionPlain (Just hostname) - uname + Nothing + Nothing Nothing (hClose con) put st diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 34c504d..b32b689 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -30,38 +30,42 @@ import Network.Xmpp.Pickle import qualified System.Random as Random -import Network.Xmpp.Sasl.Sasl import Network.Xmpp.Sasl.DigestMD5 import Network.Xmpp.Sasl.Plain import Network.Xmpp.Sasl.Types + +runSasl :: (Text.Text -> Text.Text -> Maybe Text.Text -> SaslM a) + -> Text.Text + -> Maybe Text.Text + -> XmppConMonad (Either AuthError a) +runSasl authAction authcid authzid = runErrorT $ do + hn <- gets sHostname + case hn of + Just hn' -> do + r <- authAction hn' authcid authzid + modify (\s -> s{ sUsername = Just authcid + , sAuthzid = authzid + }) + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream + return r + Nothing -> throwError AuthConnectionError + -- Uses the first supported mechanism to authenticate, if any. Updates the -- XmppConMonad state with non-password credentials and restarts the stream upon -- success. This computation wraps an ErrorT computation, which means that -- catchError can be used to catch any errors. -xmppSasl :: [SaslCredentials] -- ^ Acceptable authentication mechanisms and - -- their corresponding credentials +xmppSasl :: Text.Text + -> Maybe Text.Text + -> [SaslHandler] -- ^ Acceptable authentication + -- mechanisms and their corresponding + -- handlers -> XmppConMonad (Either AuthError ()) -xmppSasl creds = runErrorT $ do +xmppSasl authcid authzid handlers = do -- Chooses the first mechanism that is acceptable by both the client and the -- server. mechanisms <- gets $ saslMechanisms . sFeatures - let cred = L.find (\cred -> credsToName cred `elem` mechanisms) creds - unless (isJust cred) (throwError $ AuthMechanismError mechanisms) - case fromJust cred of - DigestMD5Credentials authzid authcid passwd -> ErrorT $ xmppDigestMD5 - authzid - authcid - passwd - PlainCredentials authzid authcid passwd -> ErrorT $ xmppPlain - authzid - authcid - passwd - _ -> error "xmppSasl: Mechanism not caught" - where - -- Converts the credentials to the appropriate mechanism name, corresponding to - -- the XMPP mechanism attribute. - credsToName :: SaslCredentials -> Text - credsToName (DigestMD5Credentials _ _ _) = "DIGEST-MD5" - credsToName (PlainCredentials _ _ _) = "PLAIN" - credsToName c = error $ "credsToName failed for " ++ (show c) \ No newline at end of file + case (filter (\(name,_) -> name `elem` mechanisms)) handlers of + [] -> return . Left $ AuthNoAcceptableMechanism mechanisms + (_name, handler):_ -> runSasl handler authcid authzid + diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 84ee393..c56e7a9 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Sasl.Common where @@ -6,41 +7,55 @@ import Network.Xmpp.Types import Control.Applicative ((<$>)) import Control.Monad.Error +import Control.Monad.State.Class 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 as Text import qualified Data.Text.Encoding as Text import Data.XML.Pickle import Data.XML.Types +import Data.Word (Word8) import Network.Xmpp.Monad import Network.Xmpp.Pickle import Network.Xmpp.Sasl.Types -data SaslElement = SaslSuccess - | SaslChallenge (Maybe Text) +import qualified System.Random as Random + +data SaslElement = SaslSuccess (Maybe Text.Text) + | SaslChallenge (Maybe Text.Text) + +--makeNonce :: SaslM BS.ByteString +makeNonce :: IO BS.ByteString +makeNonce = do + g <- liftIO Random.newStdGen + return $ B64.encode . BS.pack . map toWord8 . take 15 $ Random.randoms g + where + toWord8 :: Int -> Word8 + toWord8 x = fromIntegral x :: Word8 -- The element, with an -- optional round-trip value. -saslInitE :: Text -> Maybe Text -> Element +saslInitE :: Text.Text -> Maybe Text.Text -> Element saslInitE mechanism rt = Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" [("mechanism", [ContentText mechanism])] (maybeToList $ NodeContent . ContentText <$> rt) -- SASL response with text payload. -saslResponseE :: Maybe Text -> Element +saslResponseE :: Maybe Text.Text -> Element saslResponseE resp = Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" [] (maybeToList $ NodeContent . ContentText <$> resp) -xpSuccess :: PU [Node] () -xpSuccess = xpElemBlank "{urn:ietf:params:xml:ns:xmpp-sasl}success" +xpSuccess :: PU [Node] (Maybe Text.Text) +xpSuccess = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}success" + (xpOption $ xpContent xpId) -- Parses the incoming SASL data to a mapped list of pairs. pairs :: BS.ByteString -> Either String Pairs @@ -71,23 +86,24 @@ xpFailure = xpWrap (xpUnit) (xpUnit)))) -- Challenge element pickler. -xpChallenge :: PU [Node] (Maybe Text) +xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" (xpOption $ xpContent xpId) xpSaslElement = xpAlt saslSel - [ xpWrap (const SaslSuccess) (const ()) xpSuccess + [ xpWrap SaslSuccess (\(SaslSuccess x) -> x) xpSuccess , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge ] where - saslSel SaslSuccess = 0 + 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 +saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool +saslInit mechanism payload = lift . pushElement . saslInitE mechanism $ + Text.decodeUtf8 . B64.encode <$> payload pullSaslElement :: SaslM SaslElement pullSaslElement = do @@ -96,29 +112,43 @@ pullSaslElement = do Left e ->throwError $ AuthSaslFailure e Right r -> return r -pullChallenge :: SaslM (Maybe Text) +pullChallenge :: SaslM (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement case e of - SaslChallenge sc -> return sc + SaslChallenge Nothing -> return Nothing + SaslChallenge (Just scb64) + | Right sc <- B64.decode . Text.encodeUtf8 $ scb64 + -> return $ Just sc _ -> throwError AuthChallengeError saslFromJust :: Maybe a -> SaslM a saslFromJust Nothing = throwError $ AuthChallengeError saslFromJust (Just d) = return d -pullSuccess :: SaslM () +pullSuccess :: SaslM (Maybe Text.Text) pullSuccess = do e <- pullSaslElement case e of - SaslSuccess -> return () + SaslSuccess x -> return x _ -> throwError $ AuthXmlError -toPairs :: Text -> SaslM Pairs -toPairs ctext = case pairs <=< B64.decode . Text.encodeUtf8 $ ctext of +pullFinalMessage :: SaslM (Maybe Text.Text) +pullFinalMessage = do + challenge2 <- pullSaslElement + case challenge2 of + SaslSuccess x -> return x + SaslChallenge x -> do + _b <- respond Nothing + pullSuccess + return x + +toPairs :: BS.ByteString -> SaslM Pairs +toPairs ctext = case pairs ctext of Left _e -> throwError AuthChallengeError Right r -> return r -respond :: Maybe Text -> SaslM Bool -respond = lift . pushElement . saslResponseE +respond :: Maybe BS.ByteString -> SaslM Bool +respond = lift . pushElement . saslResponseE . + fmap (Text.decodeUtf8 . B64.encode) diff --git a/source/Network/Xmpp/Sasl/DigestMD5.hs b/source/Network/Xmpp/Sasl/DigestMD5.hs index 16361d4..80db9b5 100644 --- a/source/Network/Xmpp/Sasl/DigestMD5.hs +++ b/source/Network/Xmpp/Sasl/DigestMD5.hs @@ -17,7 +17,6 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.List as L -import Data.Word (Word8) import qualified Data.Text as Text import Data.Text (Text) @@ -34,7 +33,6 @@ import Network.Xmpp.Stream import Network.Xmpp.Types import Network.Xmpp.Pickle -import qualified System.Random as Random import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types @@ -46,46 +44,36 @@ xmppDigestMD5 :: Maybe Text -- Authorization identity (authzid) -> Text -- Password (authzid) -> XmppConMonad (Either AuthError ()) xmppDigestMD5 authzid authcid passwd = runErrorT $ do - realm <- gets sHostname - case realm of - Just realm' -> do - xmppDigestMD5' realm' + hn <- gets sHostname + case hn of + Just hn' -> do + xmppDigestMD5' hn' -- TODO: Save authzid modify (\s -> s{sUsername = Just authcid}) Nothing -> throwError AuthConnectionError where - xmppDigestMD5' :: Text -- ^ SASL realm - -> SaslM () - xmppDigestMD5' realm = do + xmppDigestMD5' :: Text -> SaslM () + xmppDigestMD5' hostname = do -- Push element and receive the challenge (in SaslM). _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? pairs <- toPairs =<< saslFromJust =<< pullChallenge - g <- liftIO Random.newStdGen - _b <- respond . Just $ createResponse g realm pairs - challenge2 <- pullSaslElement - case challenge2 of - SaslSuccess -> return () - SaslChallenge Nothing -> do - _b <- respond Nothing - pullSuccess - _ -> throwError AuthChallengeError + cnonce <- liftIO $ makeNonce + _b <- respond . Just $ createResponse hostname pairs cnonce + challenge2 <- pullFinalMessage _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream return () -- Produce the response to the challenge. - createResponse :: Random.RandomGen g - => g - -> Text - -> [(BS8.ByteString, BS8.ByteString)] -- Pairs - -> Text - createResponse g hostname pairs = let + createResponse :: Text + -> Pairs + -> BS.ByteString -- nonce + -> BS.ByteString + createResponse hostname pairs cnonce = let Just qop = L.lookup "qop" pairs Just nonce = L.lookup "nonce" pairs uname_ = Text.encodeUtf8 authcid passwd_ = Text.encodeUtf8 passwd -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) compatibility. - cnonce = BS.tail . BS.init . - B64.encode . BS.pack . map toWord8 . - take 8 $ Random.randoms g + nc = "00000001" digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname digest = md5Digest @@ -110,9 +98,7 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do , ["response" , digest ] , ["charset" , "utf-8" ] ] - in Text.decodeUtf8 $ B64.encode response - toWord8 :: Int -> Word8 - toWord8 x = fromIntegral x :: Word8 + in B64.encode response hash :: [BS8.ByteString] -> BS8.ByteString hash = BS8.pack . show . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") diff --git a/source/Network/Xmpp/Sasl/Plain.hs b/source/Network/Xmpp/Sasl/Plain.hs index ad8a032..32e8633 100644 --- a/source/Network/Xmpp/Sasl/Plain.hs +++ b/source/Network/Xmpp/Sasl/Plain.hs @@ -40,34 +40,38 @@ import Network.Xmpp.Pickle import qualified System.Random as Random import Data.Maybe (fromMaybe) -import qualified Data.Text as T +import qualified Data.Text as Text -import Network.Xmpp.Sasl.Sasl +import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types -xmppPlain :: Maybe T.Text - -> T.Text - -> T.Text - -> XmppConMonad (Either AuthError ()) -xmppPlain authzid authcid passwd = runErrorT $ do - _ <- lift . pushElement $ saslInitE "PLAIN" $ -- TODO: Check boolean? - Just $ Text.decodeUtf8 $ B64.encode $ Text.encodeUtf8 $ plainMessage authzid authcid passwd - 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. - _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream +-- TODO: stringprep +xmppPlain :: SaslM Text.Text + -> a + -> Text.Text + -> Maybe Text.Text + -> SaslM () +xmppPlain pw _hostname authcid authzid = do + passwd <- pw + _ <- saslInit "PLAIN" ( Just $ plainMessage authzid authcid passwd) + _ <- pullSuccess return () where -- Converts an optional authorization identity, an authentication identity, -- and a password to a \NUL-separated PLAIN message. - plainMessage :: Maybe T.Text -- Authorization identity (authzid) - -> T.Text -- Authentication identity (authcid) - -> T.Text -- Password - -> T.Text -- The PLAIN message - plainMessage authzid authcid passwd = - let authzid' = fromMaybe "" authzid in - T.concat [authzid', "\NUL", authcid, "\NUL", passwd] \ No newline at end of file + plainMessage :: Maybe Text.Text -- Authorization identity (authzid) + -> Text.Text -- Authentication identity (authcid) + -> Text.Text -- Password + -> BS.ByteString -- The PLAIN message + plainMessage authzid authcid passwd = BS.concat $ + [ authzid' + , "\NUL" + , Text.encodeUtf8 $ authcid + , "\NUL" + , Text.encodeUtf8 $ passwd + ] + where + authzid' = maybe "" Text.encodeUtf8 authzid + +plain :: SaslM Text.Text -> SaslHandler +plain passwd = ("PLAIN", xmppPlain passwd) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs new file mode 100644 index 0000000..4c4bca7 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Sasl.Scram where + +import Control.Applicative((<$>)) +import Control.Monad.Error +import Control.Monad.Trans (liftIO) +import qualified Crypto.Classes as Crypto +import qualified Crypto.HMAC as Crypto +import qualified Crypto.Hash.SHA1 as Crypto +import Data.Binary(Binary,encode) +import Data.Bits +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Char8 as BS8 (unpack) +import qualified Data.ByteString.Lazy as LBS +import Data.List (foldl1') + + +import qualified Data.Binary.Builder as Build + +import Data.Maybe (maybeToList) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Word(Word8) + +import Network.Xmpp.Sasl.Common +import Network.Xmpp.Sasl.Types + +xorBS x y = BS.pack $ BS.zipWith xor x y +merge = BS.intercalate "," + +type Hash = BS.ByteString -> BS.ByteString +type Hmac = BS.ByteString -> BS.ByteString -> BS.ByteString + + +-- -- mKey :: Crypto.Hash ctx d => d -> BS.ByteString -> MacKey ctx d +-- -- mKey x k = Crypto.MacKey k + +(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString +(+++) = BS.append + +hashToken :: (Crypto.Hash ctx hash) => hash +hashToken = undefined + +scram :: (Crypto.Hash ctx hash) + => hash -- ^ Dummy argument to determine the hash to use. You + -- can safely pass undefined or a 'hashToken' to it + -> Text.Text + -> Maybe Text.Text + -> Text.Text + -> SaslM () +scram hashToken authcid authzid' password = do + cnonce <- liftIO $ makeNonce + saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) + liftIO $ putStrLn "pulling challenge" + sFirstMessage <- saslFromJust =<< pullChallenge + liftIO $ putStrLn "pulled challenge" + pairs <- toPairs sFirstMessage + (nonce, salt, ic) <- fromPairs pairs cnonce + respond . Just $ cFinalMessage nonce salt ic sFirstMessage cnonce + liftIO $ print ic + sFinalMessage <- pullFinalMessage + return () + where + -- We need to jump through some hoops to get a polymorphic solution + encode :: Crypto.Hash ctx hash => hash -> hash -> BS.ByteString + encode _hashtoken = Crypto.encode + hash str = encode hashToken $ Crypto.hash' str + hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str + + authzid = (\z -> "a=" +++ normalize z) <$> authzid' + gs2CbindFlag = "n" -- we don't support channel binding yet + gs2Header = merge $ [ gs2CbindFlag + , maybe "" id authzid + , "" + ] + cbindData = "" -- we don't support channel binding yet + cFirstMessageBare cnonce = merge [ "n=" +++ normalize authcid + , "r=" +++ cnonce] + cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce + + fromPairs :: Pairs + -> BS.ByteString + -> SaslM (BS.ByteString, BS.ByteString, Int) + fromPairs pairs cnonce | Just nonce <- lookup "r" pairs + , cnonce `BS.isPrefixOf` nonce + , Just salt' <- lookup "s" pairs + , Right salt <- B64.decode salt' + , Just ic <- lookup "i" pairs + , [(i,"")] <- reads $ BS8.unpack ic + = return (nonce, salt, i :: Int) + fromPairs _ _ = throwError $ AuthChallengeError + + cFinalMessage nonce salt ic sfm cnonce + = merge [ cFinalMessageWOProof + , "p=" +++ B64.encode clientProof] + where + cFinalMessageWOProof = merge ["c=" +++ B64.encode gs2Header + ,"r=" +++ nonce] + saltedPassword = hi (normalize password) salt ic + clientKey = hmac saltedPassword "Client Key" + storedKey = hash clientKey + authMessage = merge [ cFirstMessageBare cnonce + , sfm + , cFinalMessageWOProof + ] + clientSignature = hmac storedKey authMessage + clientProof = clientKey `xorBS` clientSignature + -- serverKey = hmac saltedPassword "Server Key" + -- serverSignature = hmac serverKey authMessage + + -- helper + hi str salt ic = foldl1' xorBS (take ic us) + where + u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) + us = iterate (hmac str) u1 + +-- toOectets l = encode $ x + + + -- SaltedPassword := Hi(Normalize(password), salt, i) + -- ClientKey := HMAC(SaltedPassword, "Client Key") + -- StoredKey := H(ClientKey) + -- AuthMessage := client-first-message-bare + "," + + -- server-first-message + "," + + -- client-final-message-without-proof + -- ClientSignature := HMAC(StoredKey, AuthMessage) + -- ClientProof := ClientKey XOR ClientSignature + -- ServerKey := HMAC(SaltedPassword, "Server Key") + -- ServerSignature := HMAC(ServerKey, AuthMessage) + + + normalize = Text.encodeUtf8 . id -- TODO: stringprep + base64 = B64.encode + +scramSha1 :: SaslM Text.Text -> SaslHandler +scramSha1 passwd = ("SCRAM-SHA-1" + , \_hostname authcid authzid -> do + pw <- passwd + scram (hashToken :: Crypto.SHA1) authcid authzid pw + ) + +showBits x = [if testBit x i then '1' else '0' | i <- [0.. bitSize x -1]] + +toOctets :: (Binary a) => a -> [Word8] +toOctets x = LBS.unpack . encode $ x + +intToFourWord8s i = let w8s = toOctets $ i + in drop (length w8s -4) w8s \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index c7cf184..c931091 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -1,13 +1,14 @@ module Network.Xmpp.Sasl.Types where -import Control.Monad.Error -import Control.Monad.State.Strict -import Data.Text -import Network.Xmpp.Types -import Data.ByteString(ByteString) +import Control.Monad.Error +import Control.Monad.State.Strict +import Data.ByteString(ByteString) +import qualified Data.Text as Text +import Network.Xmpp.Types data AuthError = AuthXmlError - | AuthMechanismError [Text] -- ^ Wraps mechanisms offered + | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms + -- offered | AuthChallengeError | AuthStreamError StreamError -- ^ Stream error on stream restart | AuthConnectionError -- ^ No host name set in state @@ -20,4 +21,9 @@ instance Error AuthError where type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a -type Pairs = [(ByteString, ByteString)] \ No newline at end of file +type Pairs = [(ByteString, ByteString)] + +type SaslHandler = (Text.Text, Text.Text + -> Text.Text + -> Maybe Text.Text + -> SaslM ()) \ No newline at end of file diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index f7d278e..087874b 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -655,6 +655,7 @@ data XmppConnection = XmppConnection , sConnectionState :: XmppConnectionState , sHostname :: Maybe Text , sUsername :: Maybe Text + , sAuthzid :: Maybe Text , sResource :: Maybe Text , sCloseConnection :: IO () -- TODO: add default Language diff --git a/tests/Tests.hs b/tests/Tests.hs index 76b826f..47f5ea3 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -12,9 +12,9 @@ import qualified Data.Text as Text import Data.XML.Pickle import Data.XML.Types -import Network.XMPP -import Network.XMPP.IM.Presence -import Network.XMPP.Pickle +import Network.Xmpp +import Network.Xmpp.IM.Presence +import Network.Xmpp.Pickle import System.Environment import Text.XML.Stream.Elements @@ -29,7 +29,7 @@ supervisor :: JID supervisor = read "uart14@species64739.dyndns.org" -attXmpp :: STM a -> XMPP a +attXmpp :: STM a -> Xmpp a attXmpp = liftIO . atomically testNS :: Text @@ -70,7 +70,7 @@ iqResponder = do liftIO $ threadDelay 1000000 endSession -autoAccept :: XMPP () +autoAccept :: Xmpp () autoAccept = forever $ do st <- waitForPresence isPresenceSubscribe sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) From b69f8e839e3318fae27ed8775777972617bbf249 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 9 Jun 2012 14:00:33 +0200 Subject: [PATCH 5/6] add documentation to Scram.hs and Common.hs --- source/Network/Xmpp/Sasl/Common.hs | 12 +++++++ source/Network/Xmpp/Sasl/Scram.hs | 53 ++++++++++-------------------- 2 files changed, 30 insertions(+), 35 deletions(-) diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index c56e7a9..f6c8920 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -85,11 +85,14 @@ xpFailure = xpWrap xpPrim (xpUnit) (xpUnit)))) + -- Challenge element pickler. xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" (xpOption $ xpContent xpId) +-- | pickler for SaslElement +xpSaslElement :: PU [Node] SaslElement xpSaslElement = xpAlt saslSel [ xpWrap SaslSuccess (\(SaslSuccess x) -> x) xpSuccess , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge @@ -98,6 +101,7 @@ xpSaslElement = xpAlt saslSel saslSel (SaslSuccess _) = 0 saslSel (SaslChallenge _) = 1 +-- | Add quotationmarks around a byte string quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] @@ -105,6 +109,7 @@ saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool saslInit mechanism payload = lift . pushElement . saslInitE mechanism $ Text.decodeUtf8 . B64.encode <$> payload +-- | Pull the next element pullSaslElement :: SaslM SaslElement pullSaslElement = do el <- lift $ pullPickle (xpEither xpFailure xpSaslElement) @@ -112,6 +117,7 @@ pullSaslElement = do Left e ->throwError $ AuthSaslFailure e Right r -> return r +-- | Pull the next element, checking that it is a challenge pullChallenge :: SaslM (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement @@ -122,10 +128,12 @@ pullChallenge = do -> return $ Just sc _ -> throwError AuthChallengeError +-- | Extract value from Just, failing with AuthChallengeError on Nothing saslFromJust :: Maybe a -> SaslM a saslFromJust Nothing = throwError $ AuthChallengeError saslFromJust (Just d) = return d +-- | Pull the next element and check that it is success pullSuccess :: SaslM (Maybe Text.Text) pullSuccess = do e <- pullSaslElement @@ -133,6 +141,8 @@ pullSuccess = do SaslSuccess x -> return x _ -> throwError $ AuthXmlError +-- | 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 Text.Text) pullFinalMessage = do challenge2 <- pullSaslElement @@ -143,11 +153,13 @@ pullFinalMessage = do pullSuccess return x +-- | Extract p=q pairs from a challenge toPairs :: BS.ByteString -> SaslM Pairs toPairs ctext = case pairs ctext of Left _e -> throwError AuthChallengeError Right r -> return r +-- | Send a SASL response element. The content will be base64-encoded for you respond :: Maybe BS.ByteString -> SaslM Bool respond = lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) diff --git a/source/Network/Xmpp/Sasl/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs index 4c4bca7..abbc146 100644 --- a/source/Network/Xmpp/Sasl/Scram.hs +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -29,28 +29,33 @@ import Data.Word(Word8) import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types +-- | Bit-wise xor of byte strings +xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString xorBS x y = BS.pack $ BS.zipWith xor x y -merge = BS.intercalate "," - -type Hash = BS.ByteString -> BS.ByteString -type Hmac = BS.ByteString -> BS.ByteString -> BS.ByteString - --- -- mKey :: Crypto.Hash ctx d => d -> BS.ByteString -> MacKey ctx d --- -- mKey x k = Crypto.MacKey k +-- | Join byte strings with "," +merge :: [BS.ByteString] -> BS.ByteString +merge = BS.intercalate "," +-- | Infix concatenation of byte strings (+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString (+++) = BS.append +-- | A nicer name for undefined, for use as a dummy token to determin +-- the hash function to use hashToken :: (Crypto.Hash ctx hash) => hash hashToken = undefined +-- | Salted Challenge Response Authentication Mechanism (SCRAM) SASL +-- mechanism according to RFC 5802. +-- +-- This implementation is independent and polymorphic in the used hash function. scram :: (Crypto.Hash ctx hash) - => hash -- ^ Dummy argument to determine the hash to use. You - -- can safely pass undefined or a 'hashToken' to it - -> Text.Text - -> Maybe Text.Text - -> Text.Text + => hash -- ^ Dummy argument to determine the hash to use. You + -- can safely pass undefined or a 'hashToken' to it + -> Text.Text -- ^ authentication ID (username) + -> Maybe Text.Text -- ^ authorization ID + -> Text.Text -- ^ password -> SaslM () scram hashToken authcid authzid' password = do cnonce <- liftIO $ makeNonce @@ -118,35 +123,13 @@ scram hashToken authcid authzid' password = do u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) us = iterate (hmac str) u1 --- toOectets l = encode $ x - - - -- SaltedPassword := Hi(Normalize(password), salt, i) - -- ClientKey := HMAC(SaltedPassword, "Client Key") - -- StoredKey := H(ClientKey) - -- AuthMessage := client-first-message-bare + "," + - -- server-first-message + "," + - -- client-final-message-without-proof - -- ClientSignature := HMAC(StoredKey, AuthMessage) - -- ClientProof := ClientKey XOR ClientSignature - -- ServerKey := HMAC(SaltedPassword, "Server Key") - -- ServerSignature := HMAC(ServerKey, AuthMessage) - - normalize = Text.encodeUtf8 . id -- TODO: stringprep base64 = B64.encode +-- | 'scram' spezialised to the SHA-1 hash function, packaged as a SaslHandler scramSha1 :: SaslM Text.Text -> SaslHandler scramSha1 passwd = ("SCRAM-SHA-1" , \_hostname authcid authzid -> do pw <- passwd scram (hashToken :: Crypto.SHA1) authcid authzid pw ) - -showBits x = [if testBit x i then '1' else '0' | i <- [0.. bitSize x -1]] - -toOctets :: (Binary a) => a -> [Word8] -toOctets x = LBS.unpack . encode $ x - -intToFourWord8s i = let w8s = toOctets $ i - in drop (length w8s -4) w8s \ No newline at end of file From 136c5f8b1eb5df94db539c9fbcb4bb6d65dc6e4f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 9 Jun 2012 15:14:59 +0200 Subject: [PATCH 6/6] add server authentication --- source/Network/Xmpp/Sasl/Common.hs | 13 +++++++++---- source/Network/Xmpp/Sasl/Scram.hs | 30 +++++++++++++++++------------- source/Network/Xmpp/Sasl/Types.hs | 2 ++ 3 files changed, 28 insertions(+), 17 deletions(-) diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index f6c8920..c65328d 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -143,15 +143,20 @@ 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 Text.Text) +pullFinalMessage :: SaslM (Maybe BS.ByteString) pullFinalMessage = do challenge2 <- pullSaslElement case challenge2 of - SaslSuccess x -> return x + SaslSuccess x -> decode x SaslChallenge x -> do _b <- respond Nothing - pullSuccess - return x + _s <- pullSuccess + decode x + where + decode Nothing = return Nothing + decode (Just d) = case B64.decode $ Text.encodeUtf8 d of + Left _e -> throwError $ AuthChallengeError + Right x -> return $ Just x -- | Extract p=q pairs from a challenge toPairs :: BS.ByteString -> SaslM Pairs diff --git a/source/Network/Xmpp/Sasl/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs index abbc146..6750e85 100644 --- a/source/Network/Xmpp/Sasl/Scram.hs +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -65,9 +65,10 @@ scram hashToken authcid authzid' password = do liftIO $ putStrLn "pulled challenge" pairs <- toPairs sFirstMessage (nonce, salt, ic) <- fromPairs pairs cnonce - respond . Just $ cFinalMessage nonce salt ic sFirstMessage cnonce - liftIO $ print ic - sFinalMessage <- pullFinalMessage + let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce + respond $ Just cfm + finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage + unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthError return () where -- We need to jump through some hoops to get a polymorphic solution @@ -99,23 +100,26 @@ scram hashToken authcid authzid' password = do = return (nonce, salt, i :: Int) fromPairs _ _ = throwError $ AuthChallengeError - cFinalMessage nonce salt ic sfm cnonce - = merge [ cFinalMessageWOProof - , "p=" +++ B64.encode clientProof] + cFinalMessageAndVerifier nonce salt ic sfm cnonce + = (merge [ cFinalMessageWOProof + , "p=" +++ B64.encode clientProof + ] + , B64.encode serverSignature + ) where - cFinalMessageWOProof = merge ["c=" +++ B64.encode gs2Header - ,"r=" +++ nonce] + cFinalMessageWOProof = merge [ "c=" +++ B64.encode gs2Header + , "r=" +++ nonce] saltedPassword = hi (normalize password) salt ic clientKey = hmac saltedPassword "Client Key" storedKey = hash clientKey authMessage = merge [ cFirstMessageBare cnonce - , sfm - , cFinalMessageWOProof - ] + , sfm + , cFinalMessageWOProof + ] clientSignature = hmac storedKey authMessage clientProof = clientKey `xorBS` clientSignature - -- serverKey = hmac saltedPassword "Server Key" - -- serverSignature = hmac serverKey authMessage + serverKey = hmac saltedPassword "Server Key" + serverSignature = hmac serverKey authMessage -- helper hi str salt ic = foldl1' xorBS (take ic us) diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index c931091..00ea74b 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -10,6 +10,8 @@ data AuthError = AuthXmlError | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms -- offered | AuthChallengeError + | AuthServerAuthError -- ^ The server failed to authenticate + -- himself | AuthStreamError StreamError -- ^ Stream error on stream restart | AuthConnectionError -- ^ No host name set in state | AuthError -- General instance used for the Error instance