Don't run ...Many tests against mongo 2.4
This commit is contained in:
Victor Denisov
parent
e2e9f12af8
commit
173e90eb90
2 changed files with 157 additions and 132 deletions
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue