From 9ad016c043668bfe1f48422a873d0acd60bdbed5 Mon Sep 17 00:00:00 2001 From: Diego Balseiro Date: Tue, 28 Jul 2020 21:36:30 -0500 Subject: [PATCH 1/5] Add `find` using the `runCommand` operation --- Database/MongoDB/Query.hs | 58 +++++++++++++++++++++++++++++++-------- 1 file changed, 47 insertions(+), 11 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 25fc23f..7e062cc 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -29,7 +29,7 @@ module Database.MongoDB.Query ( -- ** Query Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), Projector, Limit, Order, BatchSize, - explain, find, findOne, fetch, + explain, find, findCommand, findOne, fetch, findAndModify, findAndModifyOpts, FindAndModifyOpts(..), defFamUpdateOpts, count, distinct, -- *** Cursor @@ -77,8 +77,8 @@ import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local) import Control.Monad.Trans (MonadIO, liftIO) import Data.Binary.Put (runPut) import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), - Javascript, at, valueAt, lookup, look, genObjectId, (=:), - (=?), (!?), Val(..), ObjectId, Value(..)) + Javascript, at, valueAt, lookup, look, genObjectId, merge, + (=:), (=?), (!?), Val(..), ObjectId, Value(..)) import Data.Bson.Binary (putDocument) import Data.Text (Text) import qualified Data.Text as T @@ -130,6 +130,7 @@ data Failure = | WriteConcernFailure Int String -- ^ Write concern error. It's reported only by insert, update, delete commands. Not by wire protocol. | DocNotFound Selection -- ^ 'fetch' found no document matching selection | AggregateFailure String -- ^ 'aggregate' returned an error + | FindFailure String -- ^ 'find' returned an error | CompoundFailure [Failure] -- ^ When we need to aggregate several failures and report them. | ProtocolFailure Int String -- ^ The structure of the returned documents doesn't match what we expected deriving (Show, Eq, Typeable) @@ -1032,6 +1033,33 @@ find q@Query{selection, batchSize} = do dBatch <- liftIO $ request pipe [] qr newCursor db (coll selection) batchSize dBatch +findCommand :: (MonadIO m, MonadFail m) => Query -> Action m Cursor +-- ^ Fetch documents satisfying query using the command "find" +findCommand Query{..} = do + let aColl = coll selection + response <- runCommand $ + [ "find" =: aColl + , "filter" =: selector selection + , "sort" =: sort + , "projection" =: project + , "hint" =: hint + , "skip" =: toInt32 skip + ] + ++ mconcat -- optional fields + [ "batchSize" =? toMaybe (/= 0) toInt32 batchSize + , "limit" =? toMaybe (/= 0) toInt32 limit + ] + + getCursorFromResponse aColl response FindFailure + where + toInt32 :: Integral a => a -> Int32 + toInt32 = fromIntegral + + toMaybe :: (a -> Bool) -> (a -> b) -> a -> Maybe b + toMaybe predicate f a + | predicate a = Just (f a) + | otherwise = Nothing + findOne :: (MonadIO m) => Query -> Action m (Maybe Document) -- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it findOne q = do @@ -1319,14 +1347,22 @@ aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Aggrega -- ^ Runs an aggregate and unpacks the result. See for details. aggregateCursor aColl agg _ = do response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)] - case true1 "ok" response of - True -> do - cursor :: Document <- lookup "cursor" response - firstBatch :: [Document] <- lookup "firstBatch" cursor - cursorId :: Int64 <- lookup "id" cursor - db <- thisDatabase - newCursor db aColl 0 $ return $ Batch Nothing cursorId firstBatch - False -> liftIO $ throwIO $ AggregateFailure $ at "errmsg" response + getCursorFromResponse aColl response AggregateFailure + +getCursorFromResponse + :: (MonadIO m, MonadFail m) + => Collection + -> Document + -> (String -> Failure) + -> Action m Cursor +getCursorFromResponse aColl response err + | true1 "ok" response = do + cursor <- lookup "cursor" response + firstBatch <- lookup "firstBatch" cursor + cursorId <- lookup "id" cursor + db <- thisDatabase + newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch) + | otherwise = liftIO . throwIO . err $ at "errmsg" response -- ** Group From 0c7a62fc5640c5b2d259cc416929b99ce3365afb Mon Sep 17 00:00:00 2001 From: Diego Balseiro Date: Wed, 29 Jul 2020 19:18:36 -0500 Subject: [PATCH 2/5] Add tests for `findCommand` --- test/QuerySpec.hs | 36 +++++++++++++++++++++++++++++++----- 1 file changed, 31 insertions(+), 5 deletions(-) diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index 08a33fa..53d3723 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -43,6 +43,14 @@ insertDuplicateWith testInsert = do ] return () +insertUsers :: ActionWith () -> IO () +insertUsers doTest = do + db $ insertAll_ "users" [ ["_id" =: "jane", "joined" =: parseDate "2011-03-02", "likes" =: ["golf", "racquetball"]] + , ["_id" =: "joe", "joined" =: parseDate "2012-07-02", "likes" =: ["tennis", "golf", "swimming"]] + , ["_id" =: "jill", "joined" =: parseDate "2013-11-17", "likes" =: ["cricket", "golf"]] + ] + doTest () + bigDocument :: Document bigDocument = (flip map) [1..10000] $ \i -> (fromString $ "team" ++ (show i)) =: ("team " ++ (show i) ++ " name") @@ -428,13 +436,31 @@ spec = around withCleanDatabase $ do collections <- db $ allCollections liftIO $ (L.sort collections) `shouldContain` ["team1", "team2", "team3"] - describe "aggregate" $ do + describe "aggregate" $ around insertUsers $ it "aggregates to normalize and sort documents" $ do - db $ insertAll_ "users" [ ["_id" =: "jane", "joined" =: parseDate "2011-03-02", "likes" =: ["golf", "racquetball"]] - , ["_id" =: "joe", "joined" =: parseDate "2012-07-02", "likes" =: ["tennis", "golf", "swimming"]] - , ["_id" =: "jill", "joined" =: parseDate "2013-11-17", "likes" =: ["cricket", "golf"]] - ] result <- db $ aggregate "users" [ ["$project" =: ["name" =: ["$toUpper" =: "$_id"], "_id" =: 0]] , ["$sort" =: ["name" =: 1]] ] result `shouldBe` [["name" =: "JANE"], ["name" =: "JILL"], ["name" =: "JOE"]] + + describe "findCommand" $ around insertUsers $ do + it "fetches all the records" $ do + result <- db $ rest =<< findCommand (select [] "users") + length result `shouldBe` 3 + + it "filters the records" $ do + result <- db $ rest =<< findCommand (select ["_id" =: "joe"] "users") + length result `shouldBe` 1 + + it "projects the records" $ do + result <- db $ rest =<< findCommand + (select [] "users") { project = [ "_id" =: 1 ] } + result `shouldBe` [["_id" =: "jane"], ["_id" =: "joe"], ["_id" =: "jill"]] + + it "sorts the records" $ do + result <- db $ rest =<< findCommand + (select [] "users") { project = [ "_id" =: 1 ] + , sort = [ "_id" =: 1 ] + } + result `shouldBe` [["_id" =: "jane"], ["_id" =: "jill"], ["_id" =: "joe"]] + From a3e19992873220331397d2ccf969807792973422 Mon Sep 17 00:00:00 2001 From: Diego Balseiro Date: Thu, 30 Jul 2020 13:25:19 -0500 Subject: [PATCH 3/5] Refactor `getCursorFromResponse` --- Database/MongoDB/Query.hs | 42 ++++++++++++++++++++------------------- 1 file changed, 22 insertions(+), 20 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 7e062cc..e67ab78 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -77,8 +77,8 @@ import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local) import Control.Monad.Trans (MonadIO, liftIO) import Data.Binary.Put (runPut) import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), - Javascript, at, valueAt, lookup, look, genObjectId, merge, - (=:), (=?), (!?), Val(..), ObjectId, Value(..)) + Javascript, at, valueAt, lookup, look, genObjectId, (=:), + (=?), (!?), Val(..), ObjectId, Value(..)) import Data.Bson.Binary (putDocument) import Data.Text (Text) import qualified Data.Text as T @@ -1038,19 +1038,21 @@ findCommand :: (MonadIO m, MonadFail m) => Query -> Action m Cursor findCommand Query{..} = do let aColl = coll selection response <- runCommand $ - [ "find" =: aColl - , "filter" =: selector selection - , "sort" =: sort - , "projection" =: project - , "hint" =: hint - , "skip" =: toInt32 skip - ] - ++ mconcat -- optional fields - [ "batchSize" =? toMaybe (/= 0) toInt32 batchSize - , "limit" =? toMaybe (/= 0) toInt32 limit - ] + [ "find" =: aColl + , "filter" =: selector selection + , "sort" =: sort + , "projection" =: project + , "hint" =: hint + , "skip" =: toInt32 skip + ] + ++ mconcat -- optional fields + [ "batchSize" =? toMaybe (/= 0) toInt32 batchSize + , "limit" =? toMaybe (/= 0) toInt32 limit + ] + + getCursorFromResponse aColl response + >>= either (liftIO . throwIO . FindFailure) return - getCursorFromResponse aColl response FindFailure where toInt32 :: Integral a => a -> Int32 toInt32 = fromIntegral @@ -1347,22 +1349,22 @@ aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Aggrega -- ^ Runs an aggregate and unpacks the result. See for details. aggregateCursor aColl agg _ = do response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)] - getCursorFromResponse aColl response AggregateFailure + getCursorFromResponse aColl response + >>= either (liftIO . throwIO . AggregateFailure) return getCursorFromResponse :: (MonadIO m, MonadFail m) => Collection -> Document - -> (String -> Failure) - -> Action m Cursor -getCursorFromResponse aColl response err + -> Action m (Either String Cursor) +getCursorFromResponse aColl response | true1 "ok" response = do cursor <- lookup "cursor" response firstBatch <- lookup "firstBatch" cursor cursorId <- lookup "id" cursor db <- thisDatabase - newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch) - | otherwise = liftIO . throwIO . err $ at "errmsg" response + Right <$> newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch) + | otherwise = return $ Left $ at "errmsg" response -- ** Group From c6a9ffcc63e2ed0974c048e938d4269f3cab2fa1 Mon Sep 17 00:00:00 2001 From: Diego Balseiro Date: Fri, 31 Jul 2020 13:50:33 -0500 Subject: [PATCH 4/5] Make `findCommand` tests run just for MongoDB 3.2 or superior --- Database/MongoDB/Query.hs | 2 +- test/QuerySpec.hs | 60 +++++++++++++++++++++++---------------- 2 files changed, 36 insertions(+), 26 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index e67ab78..9f1a7ae 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -1045,7 +1045,7 @@ findCommand Query{..} = do , "hint" =: hint , "skip" =: toInt32 skip ] - ++ mconcat -- optional fields + ++ mconcat -- optional fields. They should not be present if set to 0 and mongo will use defaults [ "batchSize" =? toMaybe (/= 0) toInt32 batchSize , "limit" =? toMaybe (/= 0) toInt32 limit ] diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index 53d3723..4d7435e 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -43,13 +43,20 @@ insertDuplicateWith testInsert = do ] return () -insertUsers :: ActionWith () -> IO () -insertUsers doTest = do - db $ insertAll_ "users" [ ["_id" =: "jane", "joined" =: parseDate "2011-03-02", "likes" =: ["golf", "racquetball"]] - , ["_id" =: "joe", "joined" =: parseDate "2012-07-02", "likes" =: ["tennis", "golf", "swimming"]] - , ["_id" =: "jill", "joined" =: parseDate "2013-11-17", "likes" =: ["cricket", "golf"]] - ] - doTest () +insertUsers :: IO () +insertUsers = db $ + insertAll_ "users" [ ["_id" =: "jane", "joined" =: parseDate "2011-03-02", "likes" =: ["golf", "racquetball"]] + , ["_id" =: "joe", "joined" =: parseDate "2012-07-02", "likes" =: ["tennis", "golf", "swimming"]] + , ["_id" =: "jill", "joined" =: parseDate "2013-11-17", "likes" =: ["cricket", "golf"]] + ] + +pendingIfMongoVersion :: ((Integer, Integer) -> Bool) -> SpecWith () -> Spec +pendingIfMongoVersion invalidVersion = before $ do + version <- db $ extractVersion . T.splitOn "." . at "version" <$> runCommand1 "buildinfo" + when (invalidVersion version) $ pendingWith "This test does not run in the current database version" + where + extractVersion (major:minor:_) = (read $ T.unpack major, read $ T.unpack minor) + extractVersion _ = error "Invalid version specification" bigDocument :: Document bigDocument = (flip map) [1..10000] $ \i -> (fromString $ "team" ++ (show i)) =: ("team " ++ (show i) ++ " name") @@ -436,31 +443,34 @@ spec = around withCleanDatabase $ do collections <- db $ allCollections liftIO $ (L.sort collections) `shouldContain` ["team1", "team2", "team3"] - describe "aggregate" $ around insertUsers $ + describe "aggregate" $ before_ insertUsers $ it "aggregates to normalize and sort documents" $ do result <- db $ aggregate "users" [ ["$project" =: ["name" =: ["$toUpper" =: "$_id"], "_id" =: 0]] , ["$sort" =: ["name" =: 1]] ] result `shouldBe` [["name" =: "JANE"], ["name" =: "JILL"], ["name" =: "JOE"]] - describe "findCommand" $ around insertUsers $ do - it "fetches all the records" $ do - result <- db $ rest =<< findCommand (select [] "users") - length result `shouldBe` 3 + -- This feature was introduced in MongoDB version 3.2 + -- https://docs.mongodb.com/manual/reference/command/find/ + describe "findCommand" $ pendingIfMongoVersion (< (3,2)) $ + context "when mongo version is 3.2 or superior" $ before insertUsers $ do + it "fetches all the records" $ do + result <- db $ rest =<< findCommand (select [] "users") + length result `shouldBe` 3 - it "filters the records" $ do - result <- db $ rest =<< findCommand (select ["_id" =: "joe"] "users") - length result `shouldBe` 1 + it "filters the records" $ do + result <- db $ rest =<< findCommand (select ["_id" =: "joe"] "users") + length result `shouldBe` 1 - it "projects the records" $ do - result <- db $ rest =<< findCommand - (select [] "users") { project = [ "_id" =: 1 ] } - result `shouldBe` [["_id" =: "jane"], ["_id" =: "joe"], ["_id" =: "jill"]] + it "projects the records" $ do + result <- db $ rest =<< findCommand + (select [] "users") { project = [ "_id" =: 1 ] } + result `shouldBe` [["_id" =: "jane"], ["_id" =: "joe"], ["_id" =: "jill"]] - it "sorts the records" $ do - result <- db $ rest =<< findCommand - (select [] "users") { project = [ "_id" =: 1 ] - , sort = [ "_id" =: 1 ] - } - result `shouldBe` [["_id" =: "jane"], ["_id" =: "jill"], ["_id" =: "joe"]] + it "sorts the records" $ do + result <- db $ rest =<< findCommand + (select [] "users") { project = [ "_id" =: 1 ] + , sort = [ "_id" =: 1 ] + } + result `shouldBe` [["_id" =: "jane"], ["_id" =: "jill"], ["_id" =: "joe"]] From 951109c91d09807c0c32486e1815f9c001e036ae Mon Sep 17 00:00:00 2001 From: Diego Balseiro Date: Tue, 11 Aug 2020 16:46:28 -0500 Subject: [PATCH 5/5] Use `QueryFailure` instead of adding a new error to make the change backwards compatible --- Database/MongoDB/Query.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 9f1a7ae..1d76de0 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -130,7 +130,6 @@ data Failure = | WriteConcernFailure Int String -- ^ Write concern error. It's reported only by insert, update, delete commands. Not by wire protocol. | DocNotFound Selection -- ^ 'fetch' found no document matching selection | AggregateFailure String -- ^ 'aggregate' returned an error - | FindFailure String -- ^ 'find' returned an error | CompoundFailure [Failure] -- ^ When we need to aggregate several failures and report them. | ProtocolFailure Int String -- ^ The structure of the returned documents doesn't match what we expected deriving (Show, Eq, Typeable) @@ -1051,7 +1050,7 @@ findCommand Query{..} = do ] getCursorFromResponse aColl response - >>= either (liftIO . throwIO . FindFailure) return + >>= either (liftIO . throwIO . QueryFailure (at "code" response)) return where toInt32 :: Integral a => a -> Int32 @@ -1350,7 +1349,7 @@ aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Aggrega aggregateCursor aColl agg _ = do response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)] getCursorFromResponse aColl response - >>= either (liftIO . throwIO . AggregateFailure) return + >>= either (liftIO . throwIO . AggregateFailure) return getCursorFromResponse :: (MonadIO m, MonadFail m)