Add findCommand function

`findCommand` uses command unlike `find` function that uses the wire protocol

Merge pull request #118 from juris-futura/add-find-command
This commit is contained in:
Victor Denisov 2020-08-17 20:29:51 -07:00 committed by GitHub
commit c9c9506c45
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 87 additions and 14 deletions

View file

@ -29,7 +29,7 @@ module Database.MongoDB.Query (
-- ** Query -- ** Query
Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial),
Projector, Limit, Order, BatchSize, Projector, Limit, Order, BatchSize,
explain, find, findOne, fetch, explain, find, findCommand, findOne, fetch,
findAndModify, findAndModifyOpts, FindAndModifyOpts(..), defFamUpdateOpts, findAndModify, findAndModifyOpts, FindAndModifyOpts(..), defFamUpdateOpts,
count, distinct, count, distinct,
-- *** Cursor -- *** Cursor
@ -1032,6 +1032,35 @@ find q@Query{selection, batchSize} = do
dBatch <- liftIO $ request pipe [] qr dBatch <- liftIO $ request pipe [] qr
newCursor db (coll selection) batchSize dBatch 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. They should not be present if set to 0 and mongo will use defaults
[ "batchSize" =? toMaybe (/= 0) toInt32 batchSize
, "limit" =? toMaybe (/= 0) toInt32 limit
]
getCursorFromResponse aColl response
>>= either (liftIO . throwIO . QueryFailure (at "code" response)) return
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) findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
-- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it -- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it
findOne q = do findOne q = do
@ -1319,14 +1348,22 @@ aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Aggrega
-- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details. -- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
aggregateCursor aColl agg _ = do aggregateCursor aColl agg _ = do
response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)] response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)]
case true1 "ok" response of getCursorFromResponse aColl response
True -> do >>= either (liftIO . throwIO . AggregateFailure) return
cursor :: Document <- lookup "cursor" response
firstBatch :: [Document] <- lookup "firstBatch" cursor getCursorFromResponse
cursorId :: Int64 <- lookup "id" cursor :: (MonadIO m, MonadFail m)
=> Collection
-> Document
-> 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 db <- thisDatabase
newCursor db aColl 0 $ return $ Batch Nothing cursorId firstBatch Right <$> newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch)
False -> liftIO $ throwIO $ AggregateFailure $ at "errmsg" response | otherwise = return $ Left $ at "errmsg" response
-- ** Group -- ** Group

View file

@ -43,6 +43,21 @@ insertDuplicateWith testInsert = do
] ]
return () return ()
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 :: Document
bigDocument = (flip map) [1..10000] $ \i -> (fromString $ "team" ++ (show i)) =: ("team " ++ (show i) ++ " name") bigDocument = (flip map) [1..10000] $ \i -> (fromString $ "team" ++ (show i)) =: ("team " ++ (show i) ++ " name")
@ -428,13 +443,34 @@ spec = around withCleanDatabase $ do
collections <- db $ allCollections collections <- db $ allCollections
liftIO $ (L.sort collections) `shouldContain` ["team1", "team2", "team3"] liftIO $ (L.sort collections) `shouldContain` ["team1", "team2", "team3"]
describe "aggregate" $ do describe "aggregate" $ before_ insertUsers $
it "aggregates to normalize and sort documents" $ do 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]] result <- db $ aggregate "users" [ ["$project" =: ["name" =: ["$toUpper" =: "$_id"], "_id" =: 0]]
, ["$sort" =: ["name" =: 1]] , ["$sort" =: ["name" =: 1]]
] ]
result `shouldBe` [["name" =: "JANE"], ["name" =: "JILL"], ["name" =: "JOE"]] result `shouldBe` [["name" =: "JANE"], ["name" =: "JILL"], ["name" =: "JOE"]]
-- 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 "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"]]