From 1f40d33c60d910c17ca2032e6c577b0865c24248 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 11 Jun 2012 15:56:52 +0200 Subject: [PATCH 1/2] minor formatting and documentation changes type signatures for where-local functions made xorBS, merge, and (+++) where-local removed putStrLn calls --- source/Network/Xmpp/Sasl/Scram.hs | 159 +++++++++++++++++++----------- 1 file changed, 99 insertions(+), 60 deletions(-) diff --git a/source/Network/Xmpp/Sasl/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs index 6750e85..26c289f 100644 --- a/source/Network/Xmpp/Sasl/Scram.hs +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -4,7 +4,7 @@ module Network.Xmpp.Sasl.Scram where -import Control.Applicative((<$>)) +import Control.Applicative ((<$>)) import Control.Monad.Error import Control.Monad.Trans (liftIO) import qualified Crypto.Classes as Crypto @@ -18,7 +18,6 @@ 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) @@ -29,40 +28,21 @@ 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 - --- | 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. +-- | 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 + => 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 + -> Text.Text -- ^ Authentication ID (user name) + -> Maybe Text.Text -- ^ Authorization ID + -> Text.Text -- ^ Password -> SaslM () scram hashToken authcid authzid' password = do - cnonce <- liftIO $ makeNonce + 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 @@ -71,21 +51,45 @@ scram hashToken authcid authzid' password = do unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthError return () where - -- We need to jump through some hoops to get a polymorphic solution + -- Bit-wise XOR of byte strings. + xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString + xorBS x y = BS.pack $ BS.zipWith xor x y + + -- 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 + + -- 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 :: BS.ByteString -> BS.ByteString hash str = encode hashToken $ Crypto.hash' str + + hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString 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 + authzid :: Maybe BS.ByteString + authzid = (\z -> "a=" +++ normalize z) <$> authzid' + + gs2CbindFlag :: BS.ByteString + gs2CbindFlag = "n" -- We don't support channel binding yet. + + gs2Header :: BS.ByteString + gs2Header = merge [gs2CbindFlag, maybe "" id authzid, ""] + + cbindData :: BS.ByteString + cbindData = "" -- We don't support channel binding yet. + + cFirstMessageBare :: BS.ByteString -> BS.ByteString cFirstMessageBare cnonce = merge [ "n=" +++ normalize authcid , "r=" +++ cnonce] + + cFirstMessage :: BS.ByteString -> BS.ByteString cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce fromPairs :: Pairs @@ -100,40 +104,75 @@ scram hashToken authcid authzid' password = do = return (nonce, salt, i :: Int) fromPairs _ _ = throwError $ AuthChallengeError + cFinalMessageAndVerifier :: BS.ByteString + -> BS.ByteString + -> Int + -> BS.ByteString + -> BS.ByteString + -> (BS.ByteString, BS.ByteString) cFinalMessageAndVerifier nonce salt ic sfm cnonce - = (merge [ cFinalMessageWOProof - , "p=" +++ B64.encode clientProof - ] - , B64.encode serverSignature - ) + = ( merge [ cFinalMessageWOProof + , "p=" +++ B64.encode clientProof + ] + , B64.encode serverSignature + ) where + cFinalMessageWOProof :: BS.ByteString 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 + , "r=" +++ nonce ] + + saltedPassword :: BS.ByteString + saltedPassword = hi (normalize password) salt ic + + clientKey :: BS.ByteString + clientKey = hmac saltedPassword "Client Key" + + storedKey :: BS.ByteString + storedKey = hash clientKey + + authMessage :: BS.ByteString + authMessage = merge [ cFirstMessageBare cnonce + , sfm + , cFinalMessageWOProof + ] + + clientSignature :: BS.ByteString + clientSignature = hmac storedKey authMessage + + clientProof :: BS.ByteString + clientProof = clientKey `xorBS` clientSignature + + serverKey :: BS.ByteString + serverKey = hmac saltedPassword "Server Key" + + serverSignature :: BS.ByteString + serverSignature = hmac serverKey authMessage + + -- hi() helper function. + hi :: BS.ByteString -> BS.ByteString -> Int -> BS.ByteString hi str salt ic = foldl1' xorBS (take ic us) where + u1 :: BS.ByteString u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) + + us :: [BS.ByteString] us = iterate (hmac str) u1 - normalize = Text.encodeUtf8 . id -- TODO: stringprep + normalize :: Text.Text -> BS.ByteString + normalize = Text.encodeUtf8 . id -- TODO: SASLprep Stringprep profile. + + base64 :: BS.ByteString -> BS.ByteString base64 = B64.encode --- | 'scram' spezialised to the SHA-1 hash function, packaged as a SaslHandler +-- | A nicer name for undefined, for use as a dummy token to determine the hash +-- function to use. +hashToken :: (Crypto.Hash ctx hash) => hash +hashToken = undefined + +-- | '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 - ) + pw <- passwd + scram (hashToken :: Crypto.SHA1) authcid authzid pw + ) \ No newline at end of file From b37c12628272c147aa12a9bd199e1b8b0e1033fb Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Mon, 11 Jun 2012 20:30:18 +0200 Subject: [PATCH 2/2] miscellaneous sasl changes stopped wrapping passwd in a SaslM computation for the time-being SaslHandler now takes password and does not take hostname minor formatting and documentation changes runSasl where-local SaslElement moved to Sasl/Types.hs --- source/Network/Xmpp.hs | 4 +-- source/Network/Xmpp/Sasl.hs | 42 ++++++++++++++---------------- source/Network/Xmpp/Sasl/Common.hs | 27 +++++++++---------- source/Network/Xmpp/Sasl/Plain.hs | 35 +++++++++++-------------- source/Network/Xmpp/Sasl/Scram.hs | 8 ++---- source/Network/Xmpp/Sasl/Types.hs | 20 +++++++++----- 6 files changed, 64 insertions(+), 72 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 985f99c..ed595b7 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -179,7 +179,7 @@ auth :: Text.Text -- ^ The username -- assign one -> XmppConMonad (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do - ErrorT $ xmppSasl username Nothing [scramSha1 $ return passwd] + ErrorT $ xmppSasl username Nothing passwd [scramSha1] res <- lift $ xmppBind resource - lift $ xmppStartSession + lift xmppStartSession return res diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index b32b689..a75efdf 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -34,38 +34,34 @@ 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 :: Text.Text - -> Maybe Text.Text +xmppSasl :: Text.Text -- ^ Authentication identity (user name) + -> Maybe Text.Text -- ^ Authorization identity + -> Text.Text -- ^ Password -> [SaslHandler] -- ^ Acceptable authentication -- mechanisms and their corresponding -- handlers -> XmppConMonad (Either AuthError ()) -xmppSasl authcid authzid handlers = do +xmppSasl authcid authzid passwd 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 + case (filter (\(name, _) -> name `elem` mechanisms)) handlers of [] -> return . Left $ AuthNoAcceptableMechanism mechanisms - (_name, handler):_ -> runSasl handler authcid authzid - + (_name, handler):_ -> runSasl handler authcid authzid passwd + where + runSasl :: (Text.Text -> Maybe Text.Text -> Text.Text -> SaslM a) + -> Text.Text + -> Maybe Text.Text + -> Text.Text + -> XmppConMonad (Either AuthError a) + runSasl authAction authcid authzid passwd = runErrorT $ do + r <- authAction authcid authzid passwd + modify (\s -> s{ sUsername = Just authcid + , sAuthzid = authzid + }) + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream + return r \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index c65328d..03cb432 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -26,9 +26,6 @@ import Network.Xmpp.Sasl.Types 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 @@ -53,9 +50,10 @@ saslResponseE resp = [] (maybeToList $ NodeContent . ContentText <$> resp) +-- The element. xpSuccess :: PU [Node] (Maybe Text.Text) xpSuccess = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}success" - (xpOption $ xpContent xpId) + (xpOption $ xpContent xpId) -- Parses the incoming SASL data to a mapped list of pairs. pairs :: BS.ByteString -> Either String Pairs @@ -91,7 +89,7 @@ xpChallenge :: PU [Node] (Maybe Text.Text) xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" (xpOption $ xpContent xpId) --- | pickler for SaslElement +-- | Pickler for SaslElement. xpSaslElement :: PU [Node] SaslElement xpSaslElement = xpAlt saslSel [ xpWrap SaslSuccess (\(SaslSuccess x) -> x) xpSuccess @@ -101,7 +99,7 @@ xpSaslElement = xpAlt saslSel saslSel (SaslSuccess _) = 0 saslSel (SaslChallenge _) = 1 --- | Add quotationmarks around a byte string +-- | Add quotationmarks around a byte string. quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] @@ -109,7 +107,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 +-- | Pull the next element. pullSaslElement :: SaslM SaslElement pullSaslElement = do el <- lift $ pullPickle (xpEither xpFailure xpSaslElement) @@ -117,7 +115,7 @@ pullSaslElement = do Left e ->throwError $ AuthSaslFailure e Right r -> return r --- | Pull the next element, checking that it is a challenge +-- | Pull the next element, checking that it is a challenge. pullChallenge :: SaslM (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement @@ -128,12 +126,12 @@ pullChallenge = do -> return $ Just sc _ -> throwError AuthChallengeError --- | Extract value from Just, failing with AuthChallengeError on Nothing +-- | 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 +-- | Pull the next element and check that it is success. pullSuccess :: SaslM (Maybe Text.Text) pullSuccess = do e <- pullSaslElement @@ -142,7 +140,7 @@ pullSuccess = do _ -> 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 +-- If it's a challenge, send an empty response and pull success. pullFinalMessage :: SaslM (Maybe BS.ByteString) pullFinalMessage = do challenge2 <- pullSaslElement @@ -158,14 +156,13 @@ pullFinalMessage = do Left _e -> throwError $ AuthChallengeError Right x -> return $ Just x --- | Extract p=q pairs from a challenge +-- | 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 +-- | Send a SASL response element. The content will be base64-encoded. respond :: Maybe BS.ByteString -> SaslM Bool respond = lift . pushElement . saslResponseE . - fmap (Text.decodeUtf8 . B64.encode) - + fmap (Text.decodeUtf8 . B64.encode) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Plain.hs b/source/Network/Xmpp/Sasl/Plain.hs index 32e8633..bedca29 100644 --- a/source/Network/Xmpp/Sasl/Plain.hs +++ b/source/Network/Xmpp/Sasl/Plain.hs @@ -46,32 +46,27 @@ import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types -- TODO: stringprep -xmppPlain :: SaslM Text.Text - -> a - -> Text.Text - -> Maybe Text.Text +xmppPlain :: Text.Text -- ^ Password + -> Maybe Text.Text -- ^ Authorization identity (authzid) + -> Text.Text -- ^ Authentication identity (authcid) -> SaslM () -xmppPlain pw _hostname authcid authzid = do - passwd <- pw - _ <- saslInit "PLAIN" ( Just $ plainMessage authzid authcid passwd) +xmppPlain passwd authzid authcid = do + _ <- saslInit "PLAIN" (Just $ plainMessage passwd) _ <- pullSuccess return () where -- Converts an optional authorization identity, an authentication identity, -- and a password to a \NUL-separated PLAIN message. - 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 - ] + plainMessage :: Text.Text -> BS.ByteString + plainMessage 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 +plain :: SaslHandler +plain = ("PLAIN", xmppPlain) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Scram.hs b/source/Network/Xmpp/Sasl/Scram.hs index 26c289f..9d74c36 100644 --- a/source/Network/Xmpp/Sasl/Scram.hs +++ b/source/Network/Xmpp/Sasl/Scram.hs @@ -170,9 +170,5 @@ hashToken :: (Crypto.Hash ctx hash) => hash hashToken = undefined -- | '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 - ) \ No newline at end of file +scramSha1 :: SaslHandler +scramSha1 = ("SCRAM-SHA-1", scram (hashToken :: Crypto.SHA1)) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index 00ea74b..223714c 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -11,21 +11,29 @@ data AuthError = AuthXmlError -- offered | AuthChallengeError | AuthServerAuthError -- ^ The server failed to authenticate - -- himself + -- itself | AuthStreamError StreamError -- ^ Stream error on stream restart + -- TODO: Rename AuthConnectionError? | AuthConnectionError -- ^ No host name set in state | AuthError -- General instance used for the Error instance - | AuthSaslFailure SaslFailure -- ^ defined SASL error condition + | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition deriving Show instance Error AuthError where noMsg = AuthError +data SaslElement = SaslSuccess (Maybe Text.Text) + | SaslChallenge (Maybe Text.Text) + +-- | SASL mechanism XmppConnection computation, with the possibility of throwing +-- an authentication error. 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 +-- | Tuple defining the SASL Handler's name, and a SASL mechanism computation +-- taking an authentication identity, an optional authorization identity, and a +-- password. +type SaslHandler = ( Text.Text, + Text.Text -> Maybe Text.Text -> Text.Text -> SaslM () + ) \ No newline at end of file