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