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:
commit
c9c9506c45
2 changed files with 87 additions and 14 deletions
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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"]]
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue