From 173e90eb90adde6bca8cad5fd8d6f0de495efc09 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sun, 22 Jan 2017 18:57:07 -0800 Subject: [PATCH] Don't run ...Many tests against mongo 2.4 --- Database/MongoDB/Query.hs | 22 ++-- test/QuerySpec.hs | 267 +++++++++++++++++++++----------------- 2 files changed, 157 insertions(+), 132 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index b0ab134..1d12379 100644 --- a/Database/MongoDB/Query.hs +++ b/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 - return $ WriteResult True 0 Nothing n [] [ - WriteFailure 0 -- TODO add normal index - (maybe 0 id $ lookup "ok" doc) - (show err)] [] + (Just (Array err), Nothing) -> do + return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) 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 - return $ WriteResult True 0 Nothing n [] [ - WriteFailure 0 -- TODO add normal index - (maybe 0 id $ lookup "ok" doc) - (show err)] [ + (Just (Array err), Just (Doc writeConcernErr)) -> do + return $ WriteResult True 0 Nothing n [] (map (anyToWriteError prevCount) 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 = diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index fb0712f..33232cc 100644 --- a/test/QuerySpec.hs +++ b/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,109 +197,125 @@ spec = around withCleanDatabase $ do describe "updateMany" $ do it "updates value" $ do - _id <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] - result <- db $ rest =<< find (select [] "team") - result `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "American"]] - _ <- db $ updateMany "team" [([ "_id" =: _id] - , ["$set" =: ["league" =: "European"]] - , [])] - updatedResult <- db $ rest =<< find (select [] "team") - updatedResult `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "European"]] + 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"]] + _ <- db $ updateMany "team" [([ "_id" =: _id] + , ["$set" =: ["league" =: "European"]] + , [])] + updatedResult <- db $ rest =<< find (select [] "team") + updatedResult `shouldBe` [["_id" =: _id, "name" =: "Yankees", "league" =: "European"]] it "upserts value" $ do - c <- db $ count (select [] "team") - c `shouldBe` 0 - _ <- db $ updateMany "team" [( [] - , ["name" =: "Giants", "league" =: "MLB"] - , [Upsert] - )] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - map L.sort updatedResult `shouldBe` [["league" =: "MLB", "name" =: "Giants"]] + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + c <- db $ count (select [] "team") + c `shouldBe` 0 + _ <- db $ updateMany "team" [( [] + , ["name" =: "Giants", "league" =: "MLB"] + , [Upsert] + )] + 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 - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "MiLB"] - _ <- db $ updateMany "team" [( ["name" =: "Yankees"] - , ["$set" =: ["league" =: "MLB"]] - , [MultiUpdate] - )] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB", "name" =: "Yankees"] - , ["league" =: "MLB", "name" =: "Yankees"] - ] + 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"] + , ["$set" =: ["league" =: "MLB"]] + , [MultiUpdate] + )] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB", "name" =: "Yankees"] + , ["league" =: "MLB", "name" =: "Yankees"] + ] it "updates one document when there is no Multi option" $ do - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "MiLB"] - _ <- db $ updateMany "team" [( ["name" =: "Yankees"] - , ["$set" =: ["league" =: "MLB"]] - , [] - )] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB", "name" =: "Yankees"] - , ["league" =: "MiLB", "name" =: "Yankees"] - ] + 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"] + , ["$set" =: ["league" =: "MLB"]] + , [] + )] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB", "name" =: "Yankees"] + , ["league" =: "MiLB", "name" =: "Yankees"] + ] it "can process different updates" $ do - _ <- db $ insert "team" ["name" =: "Yankees", "league" =: "American"] - _ <- db $ insert "team" ["name" =: "Giants" , "league" =: "MiLB"] - _ <- db $ updateMany "team" [ ( ["name" =: "Yankees"] - , ["$set" =: ["league" =: "MiLB"]] - , [] - ) - , ( ["name" =: "Giants"] - , ["$set" =: ["league" =: "MLB"]] - , [] - ) - ] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB" , "name" =: "Giants"] - , ["league" =: "MiLB", "name" =: "Yankees"] - ] - it "can process different updates" $ 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"] - , ["$inc" =: ["score" =: (1 :: Int)]] - , [] - ) - , ( ["name" =: "Giants"] - , ["$inc" =: ["score" =: (2 :: Int)]] - , [] - ) - ]) - failed updateResult `shouldBe` True - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] - , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (1 :: Int)] - ] - it "can handle big updates" $ do - let docs = (flip map) [0..20000] $ \i -> - ["name" =: (T.pack $ "name " ++ (show i))] - ids <- db $ insertAll "bigCollection" docs - let updateDocs = (flip map) ids (\i -> ( [ "_id" =: i] - , ["$set" =: ["name" =: ("name " ++ (show i))]] + 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"] + , ["$set" =: ["league" =: "MiLB"]] , [] - )) - _ <- db $ updateMany "team" updateDocs - updatedResult <- db $ rest =<< find (select [] "team") - forM_ updatedResult $ \r -> let (i :: ObjectId) = "_id" `at` r - in (("name" `at` r) :: String) `shouldBe` ("name" ++ (show i)) + ) + , ( ["name" =: "Giants"] + , ["$set" =: ["league" =: "MLB"]] + , [] + ) + ] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "MLB" , "name" =: "Giants"] + , ["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"] + , ["$inc" =: ["score" =: (1 :: Int)]] + , [] + ) + , ( ["name" =: "Giants"] + , ["$inc" =: ["score" =: (2 :: Int)]] + , [] + ) + ]) + failed updateResult `shouldBe` True + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] + , ["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 + let updateDocs = (flip map) ids (\i -> ( [ "_id" =: i] + , ["$set" =: ["name" =: ("name " ++ (show i))]] + , [] + )) + _ <- db $ updateMany "team" updateDocs + updatedResult <- db $ rest =<< find (select [] "team") + forM_ updatedResult $ \r -> let (i :: ObjectId) = "_id" `at` r + in (("name" `at` r) :: String) `shouldBe` ("name" ++ (show i)) describe "updateAll" $ do it "can process different updates" $ 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"] - , ["$inc" =: ["score" =: (1 :: Int)]] - , [] - ) - , ( ["name" =: "Giants"] - , ["$inc" =: ["score" =: (2 :: Int)]] - , [] - ) - ]) - failed updateResult `shouldBe` True - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] - , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (3 :: Int)] - ] + 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"] + , ["$inc" =: ["score" =: (1 :: Int)]] + , [] + ) + , ( ["name" =: "Giants"] + , ["$inc" =: ["score" =: (2 :: Int)]] + , [] + ) + ]) + failed updateResult `shouldBe` True + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + (L.sort $ map L.sort updatedResult) `shouldBe` [ ["league" =: "American", "name" =: "Yankees", "score" =: (Nothing :: Maybe Int)] + , ["league" =: "MiLB" , "name" =: "Giants" , "score" =: (3 :: Int)] + ] describe "delete" $ do it "actually deletes something" $ do @@ -336,34 +357,40 @@ spec = around withCleanDatabase $ do describe "deleteMany" $ do it "actually deletes something" $ do - _ <- db $ insert "team" ["name" =: ("Giants" :: String)] - _ <- db $ insert "team" ["name" =: ("Yankees" :: String)] - _ <- db $ deleteMany "team" [ (["name" =: ("Giants" :: String)], []) - , (["name" =: ("Yankees" :: String)], []) - ] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - length updatedResult `shouldBe` 0 + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" ["name" =: ("Giants" :: String)] + _ <- db $ insert "team" ["name" =: ("Yankees" :: String)] + _ <- db $ deleteMany "team" [ (["name" =: ("Giants" :: String)], []) + , (["name" =: ("Yankees" :: String)], []) + ] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + length updatedResult `shouldBe` 0 describe "deleteAll" $ do it "actually deletes something" $ do - _ <- db $ insert "team" [ "name" =: ("Giants" :: String) - , "score" =: (Nothing :: Maybe Int) - ] - _ <- db $ insert "team" [ "name" =: ("Yankees" :: String) - , "score" =: (1 :: Int) - ] - _ <- db $ deleteAll "team" [ (["name" =: ("Giants" :: String)], []) - , (["name" =: ("Yankees" :: String)], []) - ] - updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) - length updatedResult `shouldBe` 0 + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + _ <- db $ insert "team" [ "name" =: ("Giants" :: String) + , "score" =: (Nothing :: Maybe Int) + ] + _ <- db $ insert "team" [ "name" =: ("Yankees" :: String) + , "score" =: (1 :: Int) + ] + _ <- db $ deleteAll "team" [ (["name" =: ("Giants" :: String)], []) + , (["name" =: ("Yankees" :: String)], []) + ] + updatedResult <- db $ rest =<< find ((select [] "team") {project = ["_id" =: (0 :: Int)]}) + length updatedResult `shouldBe` 0 it "can handle big deletes" $ do - let docs = (flip map) [0..20000] $ \i -> - ["name" =: (T.pack $ "name " ++ (show i))] - _ <- db $ insertAll "bigCollection" docs - _ <- db $ deleteAll "bigCollection" $ map (\d -> (d, [])) docs - updatedResult <- db $ rest =<< find ((select [] "bigCollection") {project = ["_id" =: (0 :: Int)]}) - length updatedResult `shouldBe` 0 + wireVersion <- getWireVersion + when (wireVersion > 1) $ do + let docs = (flip map) [0..20000] $ \i -> + ["name" =: (T.pack $ "name " ++ (show i))] + _ <- db $ insertAll "bigCollection" docs + _ <- db $ deleteAll "bigCollection" $ map (\d -> (d, [])) docs + updatedResult <- db $ rest =<< find ((select [] "bigCollection") {project = ["_id" =: (0 :: Int)]}) + length updatedResult `shouldBe` 0 describe "allCollections" $ do it "returns all collections in a database" $ do