add server authentication

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

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,9 +100,12 @@ 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]
@@ -114,8 +118,8 @@ scram hashToken authcid authzid' password = do
                                      ]
         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)

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