From 0b4e3d96edaf540f48fdd89dceebb7df86a84a47 Mon Sep 17 00:00:00 2001
From: Yuras Shumovich <shumovichy@gmail.com>
Date: Mon, 30 Nov 2015 15:55:20 +0300
Subject: [PATCH] Support mongolab SCRAM auth

For some reason mongolab requires additional message exchange round.
---
 Database/MongoDB/Query.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs
index 3257519..ac6cff2 100644
--- a/Database/MongoDB/Query.hs
+++ b/Database/MongoDB/Query.hs
@@ -271,7 +271,16 @@ authSCRAMSHA1 un pw = do
                 let serverPayload2 = B64.decodeLenient . B.pack $ at "payload" server2
                 let serverData2 = parseSCRAM serverPayload2
                 let serverSigComp = Map.findWithDefault "" "v" serverData2
-                return (serverSig == serverSigComp)
+
+                shortcircuit (serverSig == serverSigComp) $ do
+                  let done = true1 "done" server2
+                  if done
+                    then return True
+                    else do
+                      let client2 = ["saslContinue" =: (1 :: Int), "conversationId" =: (at "conversationId" server1 :: Int), "payload" =: String ""]
+                      server3 <- runCommand client2
+                      shortcircuit (true1 "ok" server3) $ do
+                        return True
     where
     shortcircuit True f = f
     shortcircuit False _ = return False