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

This commit is contained in:
Victor Denisov 2017-01-22 18:57:07 -08:00
parent e2e9f12af8
commit 173e90eb90
2 changed files with 157 additions and 132 deletions

View file

@ -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 =

View file

@ -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