From ff4358c3a4f7538564f6a9b9f488b84f6f548a2c Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 11 Jun 2012 19:51:55 +0200 Subject: [PATCH] add stringprep to scram rename DigestMD5 to DigestMd5 Don't thread credentials through xmppSasl --- source/Network/Xmpp.hs | 4 +- source/Network/Xmpp/Bind.hs | 6 +- source/Network/Xmpp/Concurrent/Threads.hs | 2 +- source/Network/Xmpp/Sasl.hs | 32 ++-- .../Xmpp/Sasl/{DigestMD5.hs => DigestMd5} | 20 ++- source/Network/Xmpp/Sasl/Plain.hs | 12 +- source/Network/Xmpp/Sasl/Scram.hs | 159 +++++++++--------- source/Network/Xmpp/Sasl/StringPrep.hs | 39 +++++ source/Network/Xmpp/Sasl/Types.hs | 6 +- 9 files changed, 161 insertions(+), 119 deletions(-) rename source/Network/Xmpp/Sasl/{DigestMD5.hs => DigestMd5} (87%) create mode 100644 source/Network/Xmpp/Sasl/StringPrep.hs diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 985f99c..11eacd6 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -177,9 +177,9 @@ auth :: Text.Text -- ^ The username -> Text.Text -- ^ The password -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -- assign one - -> XmppConMonad (Either AuthError Text.Text) + -> XmppConMonad (Either AuthError JID) auth username passwd resource = runErrorT $ do - ErrorT $ xmppSasl username Nothing [scramSha1 $ return passwd] + ErrorT $ xmppSasl [scramSha1 username Nothing passwd] res <- lift $ xmppBind resource lift $ xmppStartSession return res diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs index 000a366..e87ce0c 100644 --- a/source/Network/Xmpp/Bind.hs +++ b/source/Network/Xmpp/Bind.hs @@ -24,12 +24,12 @@ bindBody = pickleElem $ -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated -- resource and extract the JID from the non-error response. -xmppBind :: Maybe Text -> XmppConMonad Text +xmppBind :: Maybe Text -> XmppConMonad JID xmppBind rsrc = do answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) let Right IQResult{iqResultPayload = Just b} = answer -- TODO: Error handling - let Right (JID _n _d (Just r)) = unpickleElem jidP b - return r + let Right jid = unpickleElem jidP b + return jid where -- Extracts the character data in the `jid' element. jidP :: PU [Node] JID diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 656bca3..5d81db3 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -54,7 +54,7 @@ readWorker messageC presenceC stanzaC iqHands handlers stateRef = [ Ex.Handler $ \(Interrupt t) -> do void $ handleInterrupts [t] return Nothing - , Ex.Handler $ \e -> noCon handlers (e :: StreamError) + , Ex.Handler $ \(e :: StreamError) -> noCon handlers e ] liftIO . atomically $ do case res of diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index b32b689..fe91a57 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -30,42 +30,32 @@ import Network.Xmpp.Pickle import qualified System.Random as Random -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 - }) +runSasl :: SaslM a -> XmppConMonad (Either AuthError a) +runSasl authAction = runErrorT $ do + cs <- gets sConnectionState + case cs of + XmppConnectionClosed -> throwError AuthConnectionError + _ -> do + r <- authAction _ <- 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 :: Text.Text - -> Maybe Text.Text - -> [SaslHandler] -- ^ Acceptable authentication +xmppSasl :: [SaslHandler] -- ^ Acceptable authentication -- mechanisms and their corresponding -- handlers -> XmppConMonad (Either AuthError ()) -xmppSasl authcid authzid handlers = do +xmppSasl handlers = do -- Chooses the first mechanism that is acceptable by both the client and the -- server. mechanisms <- gets $ saslMechanisms . sFeatures case (filter (\(name,_) -> name `elem` mechanisms)) handlers of [] -> return . Left $ AuthNoAcceptableMechanism mechanisms - (_name, handler):_ -> runSasl handler authcid authzid - + (_name, handler):_ -> runSasl handler diff --git a/source/Network/Xmpp/Sasl/DigestMD5.hs b/source/Network/Xmpp/Sasl/DigestMd5 similarity index 87% rename from source/Network/Xmpp/Sasl/DigestMD5.hs rename to source/Network/Xmpp/Sasl/DigestMd5 index 80db9b5..2f3b6e1 100644 --- a/source/Network/Xmpp/Sasl/DigestMD5.hs +++ b/source/Network/Xmpp/Sasl/DigestMd5 @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.DigestMD5 where +module Network.Xmpp.Sasl.DigestMd5 where import Control.Applicative import Control.Arrow (left) @@ -39,11 +39,11 @@ import Network.Xmpp.Sasl.Types -xmppDigestMD5 :: Maybe Text -- Authorization identity (authzid) +xmppDigestMd5 :: Maybe Text -- Authorization identity (authzid) -> Text -- Authentication identity (authzid) -> Text -- Password (authzid) - -> XmppConMonad (Either AuthError ()) -xmppDigestMD5 authzid authcid passwd = runErrorT $ do + -> SaslM () +xmppDigestMd5 authzid authcid passwd = do hn <- gets sHostname case hn of Just hn' -> do @@ -68,7 +68,7 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do -> BS.ByteString -- nonce -> BS.ByteString createResponse hostname pairs cnonce = let - Just qop = L.lookup "qop" pairs + Just qop = L.lookup "qop" pairs -- TODO: proper handling Just nonce = L.lookup "nonce" pairs uname_ = Text.encodeUtf8 authcid passwd_ = Text.encodeUtf8 passwd @@ -123,4 +123,12 @@ xmppDigestMD5 authzid authcid passwd = runErrorT $ do , cnonce ] ha2 = hash ["AUTHENTICATE", digestURI] - in hash [ha1, nonce, nc, cnonce, qop, ha2] \ No newline at end of file + in hash [ha1, nonce, nc, cnonce, qop, ha2] + +digestMd5 :: Maybe Text -- Authorization identity (authzid) + -> Text -- Authentication identity (authzid) + -> Text -- Password (authzid) + -> SaslHandler +digestMd5 authzid authcid password = ( "DIGEST-MD5" + , xmppDigestMd5 authzid authcid password + ) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Plain.hs b/source/Network/Xmpp/Sasl/Plain.hs index 32e8633..227c95f 100644 --- a/source/Network/Xmpp/Sasl/Plain.hs +++ b/source/Network/Xmpp/Sasl/Plain.hs @@ -46,13 +46,11 @@ import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types -- TODO: stringprep -xmppPlain :: SaslM Text.Text - -> a - -> Text.Text +xmppPlain :: Text.Text -> Maybe Text.Text + -> Text.Text -> SaslM () -xmppPlain pw _hostname authcid authzid = do - passwd <- pw +xmppPlain authcid authzid passwd = do _ <- saslInit "PLAIN" ( Just $ plainMessage authzid authcid passwd) _ <- pullSuccess return () @@ -73,5 +71,5 @@ xmppPlain pw _hostname authcid authzid = do where authzid' = maybe "" Text.encodeUtf8 authzid -plain :: SaslM Text.Text -> SaslHandler -plain passwd = ("PLAIN", xmppPlain passwd) \ No newline at end of file +plain :: Text.Text -> Maybe Text.Text -> Text.Text -> SaslHandler +plain authcid authzid passwd = ("PLAIN", xmppPlain authcid authzid passwd) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs index 6750e85..3f04f46 100644 --- a/source/Network/Xmpp/Sasl/Scram.hs +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -27,6 +27,7 @@ import qualified Data.Text.Encoding as Text import Data.Word(Word8) import Network.Xmpp.Sasl.Common +import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types -- | Bit-wise xor of byte strings @@ -57,83 +58,91 @@ scram :: (Crypto.Hash ctx hash) -> Maybe Text.Text -- ^ authorization ID -> Text.Text -- ^ password -> 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 - 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 () +scram hashToken authcid authzid password = case credentials of + Nothing -> throwError $ AuthStringPrepError + Just (ac, az, pw) -> scramhelper hashToken ac az pw 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 - - cFinalMessageAndVerifier nonce salt ic sfm cnonce - = (merge [ cFinalMessageWOProof - , "p=" +++ B64.encode clientProof - ] - , B64.encode serverSignature - ) + credentials = do + ac <- normalizeUsername authcid + az <- case authzid of + Nothing -> Just Nothing + Just az' -> Just <$> normalizeUsername az' + pw <- normalizePassword password + return (ac, az, pw) + scramhelper hashToken authcid authzid' password = do + cnonce <- liftIO $ makeNonce + saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) + sFirstMessage <- saslFromJust =<< pullChallenge + pairs <- toPairs sFirstMessage + (nonce, salt, ic) <- fromPairs pairs cnonce + 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 - 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) + -- 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=" +++ Text.encodeUtf8 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=" +++ Text.encodeUtf8 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 + + cFinalMessageAndVerifier nonce salt ic sfm cnonce + = (merge [ cFinalMessageWOProof + , "p=" +++ B64.encode clientProof + ] + , B64.encode serverSignature + ) where - u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) - us = iterate (hmac str) u1 - - normalize = Text.encodeUtf8 . id -- TODO: stringprep - base64 = B64.encode + cFinalMessageWOProof = merge [ "c=" +++ B64.encode gs2Header + , "r=" +++ nonce] + saltedPassword = hi (Text.encodeUtf8 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 -- | '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 - ) +scramSha1 :: Text.Text -- ^ username + -> Maybe Text.Text -- ^ authorization ID + -> Text.Text -- ^ password + -> SaslHandler +scramSha1 authcid authzid passwd = + ("SCRAM-SHA-1" + , scram (hashToken :: Crypto.SHA1) authcid authzid passwd + ) diff --git a/source/Network/Xmpp/Sasl/StringPrep.hs b/source/Network/Xmpp/Sasl/StringPrep.hs new file mode 100644 index 0000000..27de3d6 --- /dev/null +++ b/source/Network/Xmpp/Sasl/StringPrep.hs @@ -0,0 +1,39 @@ +module Network.Xmpp.Sasl.StringPrep where + +import Text.StringPrep + +saslPrepQuery = Profile + [b1] + True + [ c12 + , c21 + , c22 + , c3 + , c4 + , c5 + , c6 + , c7 + , c8 + , c9 + ] + True + +saslPrepStore = Profile + [b1] + True + [ a1 + , c12 + , c21 + , c22 + , c3 + , c4 + , c5 + , c6 + , c7 + , c8 + , c9 + ] + True + +normalizePassword = runStringPrep saslPrepStore +normalizeUsername = runStringPrep saslPrepQuery \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index 00ea74b..c4caf3a 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -16,6 +16,7 @@ data AuthError = AuthXmlError | AuthConnectionError -- ^ No host name set in state | AuthError -- General instance used for the Error instance | AuthSaslFailure SaslFailure -- ^ defined SASL error condition + | AuthStringPrepError -- ^ StringPrep failed deriving Show instance Error AuthError where @@ -25,7 +26,4 @@ type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a type Pairs = [(ByteString, ByteString)] -type SaslHandler = (Text.Text, Text.Text - -> Text.Text - -> Maybe Text.Text - -> SaslM ()) \ No newline at end of file +type SaslHandler = (Text.Text, SaslM ()) \ No newline at end of file