diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 25fc23f..1d76de0 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 @@ -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 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 diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index 08a33fa..4d7435e 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -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"]] +