From 136c5f8b1eb5df94db539c9fbcb4bb6d65dc6e4f Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Sat, 9 Jun 2012 15:14:59 +0200
Subject: [PATCH] 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