Add findCommand function

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

Merge pull request #118 from juris-futura/add-find-command

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 <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
+    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)
-          db <- thisDatabase
+  => Collection
-          newCursor db aColl 0 $ return $ Batch Nothing cursorId  firstBatch
+  -> Document
-        False -> liftIO $ throwIO $ AggregateFailure $ at "errmsg" response
+  -> 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
 

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"]]
+