From 8cfcb3894a88108e67e85e8cf27520515f5254f0 Mon Sep 17 00:00:00 2001 From: Sean Leather Date: Wed, 18 Mar 2015 02:34:01 -0700 Subject: [PATCH 1/3] Refactor to reduce duplicate code --- test/QuerySpec.hs | 66 +++++++++++++---------------------------------- 1 file changed, 18 insertions(+), 48 deletions(-) diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index db619f0..f688eae 100644 --- a/test/QuerySpec.hs +++ b/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 - _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 + before (insertDuplicateWith insertMany `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 - _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 + before (insertDuplicateWith insertMany_ `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 - _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 + before (insertDuplicateWith insertAll `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,10 @@ spec = around withCleanDatabase $ do ids `shouldBe` () context "Insert a document with duplicating key" $ do - let insertDuplicatingDocument = 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 + before (insertDuplicateWith insertAll_ `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 From 6fd7c099a5ed335c96a3e197512458c8c5f5c70b Mon Sep 17 00:00:00 2001 From: Sean Leather Date: Sun, 22 Mar 2015 18:05:04 +0200 Subject: [PATCH 2/3] Install the dependencies for all packages --- .travis.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 164ef2b..0b543f3 100644 --- a/.travis.yml +++ b/.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: From 77cde91c61a5cc8caad18d5f2aaade7a9a5b90d2 Mon Sep 17 00:00:00 2001 From: Sean Leather Date: Wed, 18 Mar 2015 03:35:51 -0700 Subject: [PATCH 3/3] Add aggregate test --- mongoDB.cabal | 5 +++++ test/QuerySpec.hs | 11 +++++++++++ test/TestImport.hs | 27 +++++++++++++++++++++++++++ 3 files changed, 43 insertions(+) diff --git a/mongoDB.cabal b/mongoDB.cabal index 02660d7..9ef04b1 100644 --- a/mongoDB.cabal +++ b/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 diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs index f688eae..8c5f93c 100644 --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -121,3 +121,14 @@ spec = around withCleanDatabase $ do it "raises exception" $ 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"]] diff --git a/test/TestImport.hs b/test/TestImport.hs index 9b99618..2294beb 100644 --- a/test/TestImport.hs +++ b/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"))