Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Add findCommand function

Browse source 
`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
Show stats Download patch file Download diff file Expand all files Collapse all files

55
Database/MongoDB/Query.hs
View file

@ -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
@ -1032,6 +1032,35 @@ 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. 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)
-- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it
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.
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
>>= either (liftIO . throwIO . AggregateFailure) return
getCursorFromResponse
:: (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
Right <$> newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch)
| otherwise = return $ Left $ at "errmsg" response
-- ** Group

46
test/QuerySpec.hs
View file

@ -43,6 +43,21 @@ insertDuplicateWith testInsert = do
]
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 = (flip map) [1..10000] $ \i -> (fromString $ "team" ++ (show i)) =: ("team " ++ (show i) ++ " name")
@ -428,13 +443,34 @@ spec = around withCleanDatabase $ do
collections <- db $ allCollections
liftIO $ (L.sort collections) `shouldContain` ["team1", "team2", "team3"]
describe "aggregate" $ do
describe "aggregate" $ before_ 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"]]
-- 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"]]