Don't run ...Many tests against mongo 2.4

Database/MongoDB/Query.hs

@@ -43,7 +43,7 @@ module Database.MongoDB.Query (
     MRResult, mapReduce, runMR, runMR',
     -- * Command
     Command, runCommand, runCommand1,
-    eval, retrieveServerData
+    eval, retrieveServerData, ServerData(..)
 ) where
 
 import Prelude hiding (lookup)
@@ -77,7 +77,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..))
 import Data.Binary.Put (runPut)
 import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool),
                   Javascript, at, valueAt, lookup, look, genObjectId, (=:),
-                  (=?), (!?), Val(..), ObjectId)
+                  (=?), (!?), Val(..), ObjectId, Value(..))
 import Data.Bson.Binary (putDocument)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -907,27 +907,25 @@ deleteBlock ordered col (prevCount, docs) = do
       let n = fromMaybe 0 $ doc !? "n"
       case (look "writeErrors" doc, look "writeConcernError" doc) of
         (Nothing, Nothing) -> return $ WriteResult False 0 Nothing n [] [] []
-        (Just err, Nothing) -> do
+        (Just (Array err), Nothing) -> do
-          return $ WriteResult True 0 Nothing n [] [
+          return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) []
-                     WriteFailure 0 -- TODO add normal index
-                                  (maybe 0 id $ lookup "ok" doc)
-                                  (show err)] []
         (Nothing, Just (Doc err)) -> do
           return $ WriteResult True 0 Nothing n [] [] [
                               WriteConcernError
                                 (fromMaybe (-1) $ err !? "code")
                                 (fromMaybe "" $ err !? "errmsg")
                                 ]
-        (Just err, Just (Doc writeConcernErr)) -> do
+        (Just (Array err), Just (Doc writeConcernErr)) -> do
-          return $ WriteResult True 0 Nothing n [] [
+          return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) err) [
-                     WriteFailure 0 -- TODO add normal index
-                                  (maybe 0 id $ lookup "ok" doc)
-                                  (show err)] [
                      WriteConcernError
                                 (fromMaybe (-1) $ writeConcernErr !? "code")
                                 (fromMaybe "" $ writeConcernErr !? "errmsg")
                                   ]
 
+anyToWriteError :: Int -> Value -> Failure
+anyToWriteError ind (Doc d) = docToWriteError d
+anyToWriteError ind _ = WriteFailure ind (-1) "Unknown bson value"
+
 -- * Read
 
 data ReadMode =

test/QuerySpec.hs

@@ -5,7 +5,7 @@ module QuerySpec (spec) where
 import Data.String (IsString(..))
 import TestImport
 import Control.Exception
-import Control.Monad (forM_)
+import Control.Monad (forM_, when)
 import System.Environment (getEnv)
 import System.IO.Error (catchIOError)
 import qualified Data.List as L
@@ -23,6 +23,11 @@ db action = do
     close pipe
     return result
 
+getWireVersion :: IO Int
+getWireVersion = db $ do
+    sd <- retrieveServerData
+    return $ maxWireVersion sd
+
 withCleanDatabase :: ActionWith () -> IO ()
 withCleanDatabase action = dropDB >> action () >> dropDB >> return ()
   where
@@ -192,6 +197,8 @@ spec = around withCleanDatabase $ do
 
   describe "updateMany" $ do
     it "updates value" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         _id <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"]
         result <- db $ rest =<< find (select [] "team")
         result `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "American"]]
@@ -201,6 +208,8 @@ spec = around withCleanDatabase $ do
         updatedResult <- db $ rest =<< find (select [] "team")
         updatedResult `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "European"]]
     it "upserts value" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         c <- db $ count (select [] "team")
         c `shouldBe` 0
         _ <- db $ updateMany "team" [( []
@@ -210,6 +219,8 @@ spec = around withCleanDatabase $ do
         updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]})
         map L.sort updatedResult `shouldBe` [["league" =: "MLB", "name" =: "Giants"]]
     it "updates all documents with Multi enabled" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"]
         _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "MiLB"]
         _ <- db $ updateMany "team" [( ["name" =: "Yankees"]
@@ -221,6 +232,8 @@ spec = around withCleanDatabase $ do
                                                        , ["league" =: "MLB", "name" =: "Yankees"]
                                                        ]
     it "updates one document when there is no Multi option" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"]
         _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "MiLB"]
         _ <- db $ updateMany "team" [( ["name" =: "Yankees"]
@@ -232,6 +245,8 @@ spec = around withCleanDatabase $ do
                                                        , ["league" =: "MiLB", "name" =: "Yankees"]
                                                        ]
     it "can process different updates" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"]
         _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB"]
         _ <- db $ updateMany "team" [ ( ["name" =: "Yankees"]
@@ -248,6 +263,8 @@ spec = around withCleanDatabase $ do
                                                        , ["league" =: "MiLB", "name" =: "Yankees"]
                                                        ]
     it "can process different updates" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American", "score" =: (Nothing :: Maybe Int)]
         _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB", "score" =: (1 :: Int)]
         updateResult <- (db $ updateMany "team" [ ( ["name" =: "Yankees"]
@@ -265,6 +282,8 @@ spec = around withCleanDatabase $ do
                                                        , ["league" =: "MiLB"    , "name" =: "Giants" , "score" =: (1 :: Int)]
                                                        ]
     it "can handle big updates" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         let docs = (flip map) [0..20000] $ \i ->
                 ["name" =: (T.pack $ "name " ++ (show i))]
         ids <- db $ insertAll "bigCollection" docs
@@ -279,6 +298,8 @@ spec = around withCleanDatabase $ do
 
   describe "updateAll" $ do
     it "can process different updates" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American", "score" =: (Nothing :: Maybe Int)]
         _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB", "score" =: (1 :: Int)]
         updateResult <- (db $ updateAll "team" [ ( ["name" =: "Yankees"]
@@ -336,6 +357,8 @@ spec = around withCleanDatabase $ do
 
   describe "deleteMany" $ do
     it "actually deletes something" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         _ <- db $ insert "team" ["name" =: ("Giants" :: String)]
         _ <- db $ insert "team" ["name" =: ("Yankees" :: String)]
         _ <- db $ deleteMany "team" [ (["name" =: ("Giants" :: String)], [])
@@ -346,6 +369,8 @@ spec = around withCleanDatabase $ do
 
   describe "deleteAll" $ do
     it "actually deletes something" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         _ <- db $ insert "team" [ "name"  =: ("Giants" :: String)
                                 , "score" =: (Nothing :: Maybe Int)
                                 ]
@@ -358,6 +383,8 @@ spec = around withCleanDatabase $ do
         updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]})
         length updatedResult `shouldBe` 0
     it "can handle big deletes" $ do
+      wireVersion <- getWireVersion
+      when (wireVersion > 1) $ do
         let docs = (flip map) [0..20000] $ \i ->
                 ["name" =: (T.pack $ "name " ++ (show i))]
         _ <- db $ insertAll "bigCollection" docs