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