Merge pull request #15 from docmunch/aggregate-test

Add aggregate test

.travis.yml

@@ -25,7 +25,9 @@ before_install:
 
 install:
  - travis_retry cabal update
- - cabal install --only-dependencies --enable-tests
+ # Install the combined dependencies for this package and all other packages
+ # needed to reduce conflicts.
+ - cabal install --only-dependencies --enable-tests . hpc-coveralls
  - cabal install hpc-coveralls
 
 script:

mongoDB.cabal

@@ -63,6 +63,11 @@ test-suite test
                  , base
                  , mtl
                  , hspec >= 2
+                 -- Keep supporting the old-locale and time < 1.5 packages for
+                 -- now. It's too difficult to support old versions of GHC and
+                 -- the new version of time.
+                 , old-locale
+                 , time
 
   default-language: Haskell2010
   default-extensions: OverloadedStrings

test/QuerySpec.hs

@@ -20,6 +20,16 @@ withCleanDatabase action = dropDB >> action () >> dropDB >> return ()
   where
     dropDB = db $ dropDatabase testDBName
 
+insertDuplicateWith :: (Collection -> [Document] -> Action IO a) -> IO ()
+insertDuplicateWith testInsert = do
+  _id <- db $ insert "team" ["name" =: "Dodgers", "league" =: "American"]
+  _ <- db $ testInsert "team" [ ["name" =: "Yankees", "league" =: "American"]
+                              -- Try to insert document with duplicate key
+                              , ["name" =: "Dodgers", "league" =: "American", "_id" =: _id]
+                              , ["name" =: "Indians", "league" =: "American"]
+                              ]
+  return ()
+
 spec :: Spec
 spec = around withCleanDatabase $ do
   describe "useDb" $ do
@@ -50,17 +60,7 @@ spec = around withCleanDatabase $ do
                         , ["_id" =: _id2, "name" =: "Dodgers", "league" =: "American"]
                         ]
     context "Insert a document with duplicating key" $ do
-      let insertDuplicatingDocument = do
+      before (insertDuplicateWith insertMany `catch` \(_ :: Failure) -> return ()) $ do
-            _id <- db $ insert "team" ["name" =: "Dodgers", "league" =: "American"]
-            _ <- db $ insertMany "team" [ ["name" =: "Yankees", "league" =: "American"]
-                                            -- Try to insert document with
-                                            -- duplicate key
-                                            , ["name" =: "Dodgers", "league" =: "American", "_id" =: _id]
-                                            , ["name" =: "Indians", "league" =: "American"]
-                                            ]
-            return ()
-
-      before (insertDuplicatingDocument `catch` \(_ :: Failure) -> return ()) $ do
         it "inserts documents before it" $
           db (count $ select ["name" =: "Yankees", "league" =: "American"] "team") `shouldReturn` 1
 
@@ -68,7 +68,7 @@ spec = around withCleanDatabase $ do
           db (count $ select ["name" =: "Indians", "league" =: "American"] "team") `shouldReturn` 0
 
       it "raises exception" $
-        insertDuplicatingDocument `shouldThrow` anyException
+        insertDuplicateWith insertMany `shouldThrow` anyException
       -- TODO No way to call getLastError?
 
   describe "insertMany_" $ do
@@ -79,23 +79,13 @@ spec = around withCleanDatabase $ do
       ids `shouldBe` ()
 
     context "Insert a document with duplicating key" $ do
-      let insertDuplicatingDocument = do
+      before (insertDuplicateWith insertMany_ `catch` \(_ :: Failure) -> return ()) $ do
-            _id <- db $ insert "team" ["name" =: "Dodgers", "league" =: "American"]
-            _ <- db $ insertMany_ "team" [ ["name" =: "Yankees", "league" =: "American"]
-                                             -- Try to insert document with
-                                             -- duplicate key
-                                             , ["name" =: "Dodgers", "league" =: "American", "_id" =: _id]
-                                             , ["name" =: "Indians", "league" =: "American"]
-                                             ]
-            return ()
-
-      before (insertDuplicatingDocument `catch` \(_ :: Failure) -> return ()) $ do
         it "inserts documents before it" $
           db (count $ select ["name" =: "Yankees", "league" =: "American"] "team") `shouldReturn` 1
         it "doesn't insert documents after it" $
           db (count $ select ["name" =: "Indians", "league" =: "American"] "team") `shouldReturn` 0
       it "raises exception" $
-        insertDuplicatingDocument `shouldThrow` anyException
+        insertDuplicateWith insertMany_ `shouldThrow` anyException
 
   describe "insertAll" $ do
     it "inserts documents to the collection and returns their _ids" $ do
@@ -108,23 +98,13 @@ spec = around withCleanDatabase $ do
                         ]
 
     context "Insert a document with duplicating key" $ do
-      let insertDuplicatingDocument = do
+      before (insertDuplicateWith insertAll `catch` \(_ :: Failure) -> return ()) $ do
-            _id <- db $ insert "team" ["name" =: "Dodgers", "league" =: "American"]
-            _ <- db $ insertAll "team" [ ["name" =: "Yankees", "league" =: "American"]
-                                            -- Try to insert document with
-                                            -- duplicate key
-                                            , ["name" =: "Dodgers", "league" =: "American", "_id" =: _id]
-                                            , ["name" =: "Indians", "league" =: "American"]
-                                            ]
-            return ()
-
-      before (insertDuplicatingDocument `catch` \(_ :: Failure) -> return ()) $ do
         it "inserts all documents which can be inserted" $ do
           db (count $ select ["name" =: "Yankees", "league" =: "American"] "team") `shouldReturn` 1
           db (count $ select ["name" =: "Indians", "league" =: "American"] "team") `shouldReturn` 1
 
       it "raises exception" $
-        insertDuplicatingDocument `shouldThrow` anyException
+        insertDuplicateWith insertAll `shouldThrow` anyException
 
   describe "insertAll_" $ do
     it "inserts documents to the collection and returns their _ids" $ do
@@ -134,20 +114,21 @@ spec = around withCleanDatabase $ do
       ids `shouldBe` ()
 
     context "Insert a document with duplicating key" $ do
-      let insertDuplicatingDocument = do
+      before (insertDuplicateWith insertAll_ `catch` \(_ :: Failure) -> return ()) $ do
-            _id <- db $ insert "team" ["name" =: "Dodgers", "league" =: "American"]
-            _ <- db $ insertAll_ "team" [ ["name" =: "Yankees", "league" =: "American"]
-                                             -- Try to insert document with
-                                             -- duplicate key
-                                             , ["name" =: "Dodgers", "league" =: "American", "_id" =: _id]
-                                             , ["name" =: "Indians", "league" =: "American"]
-                                             ]
-            return ()
-
-      before (insertDuplicatingDocument `catch` \(_ :: Failure) -> return ()) $ do
         it "inserts all documents which can be inserted" $ do
           db (count $ select ["name" =: "Yankees", "league" =: "American"] "team") `shouldReturn` 1
           db (count $ select ["name" =: "Indians", "league" =: "American"] "team") `shouldReturn` 1
 
       it "raises exception" $
-        insertDuplicatingDocument `shouldThrow` anyException
+        insertDuplicateWith insertAll_ `shouldThrow` anyException
+
+  describe "aggregate" $ 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]]
+                                       , ["$sort" =: ["name" =: 1]]
+                                       ]
+      result `shouldBe` [["name" =: "JANE"], ["name" =: "JILL"], ["name" =: "JOE"]]

test/TestImport.hs

@@ -1,7 +1,34 @@
+{-# LANGUAGE CPP #-}
+
 module TestImport (
+  module TestImport,
   module Export
 ) where
 
 import Test.Hspec as Export hiding (Selector)
 import Database.MongoDB as Export
 import Control.Monad.Trans as Export (MonadIO, liftIO) 
+import Data.Maybe (fromJust)
+import Data.Time (ParseTime, UTCTime)
+import qualified Data.Time as Time
+
+-- We support the old version of time because it's easier than trying to use
+-- only the new version and test older GHC versions.
+#if MIN_VERSION_time(1,5,0)
+import Data.Time.Format (defaultTimeLocale, iso8601DateFormat)
+#else
+import System.Locale (defaultTimeLocale, iso8601DateFormat)
+#endif
+
+parseTime :: ParseTime t => String -> String -> t
+#if MIN_VERSION_time(1,5,0)
+parseTime = Time.parseTimeOrError True defaultTimeLocale
+#else
+parseTime fmt = fromJust . Time.parseTime defaultTimeLocale fmt
+#endif
+
+parseDate :: String -> UTCTime
+parseDate = parseTime (iso8601DateFormat Nothing)
+
+parseDateTime :: String -> UTCTime
+parseDateTime = parseTime (iso8601DateFormat (Just "%H:%M:%S"))