From 34047e1f5f7c06c0aa09f1c3069dffc9b4faffff Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 28 May 2021 15:34:56 -0600 Subject: [PATCH] Pass ConnectionPool to tests (#262) * rewriting tests * tests now run in 1.45 seconds * tests pass * fix json * fix tests * add helper for setting the database state * clean things up a bit --- .gitignore | 1 + Makefile | 14 +- esqueleto.cabal | 6 +- test/Common/Test.hs | 1595 ++++++++++++++++---------------- test/Common/Test/Import.hs | 70 +- test/Common/Test/Select.hs | 32 +- test/MySQL/Test.hs | 123 +-- test/PostgreSQL/MigrateJSON.hs | 17 +- test/PostgreSQL/Test.hs | 1040 ++++++++++----------- test/SQLite/Test.hs | 269 +++--- 10 files changed, 1532 insertions(+), 1635 deletions(-) diff --git a/.gitignore b/.gitignore index 3e4fcf1..d4f5a40 100644 --- a/.gitignore +++ b/.gitignore @@ -6,4 +6,5 @@ stack.yaml.lock .cabal-sandbox/ cabal.sandbox.config .hspec-failures +*.sqlite* cabal.project.freeze diff --git a/Makefile b/Makefile index 4c75b77..fd3b937 100644 --- a/Makefile +++ b/Makefile @@ -21,7 +21,19 @@ test-ghci: stack ghci esqueleto:test:sqlite test-ghcid: - ghcid -c "stack ghci --ghci-options -fobject-code esqueleto:test:sqlite" + ghcid -c "stack ghci --ghci-options -fobject-code esqueleto --test" \ + --warnings \ + --restart "stack.yaml" \ + --restart "esqueleto.cabal" \ + --test main + +test-ghcid-build: + ghcid -c "stack ghci --ghci-options -fobject-code esqueleto --test" \ + --warnings \ + --restart "stack.yaml" \ + --restart "esqueleto.cabal" + + init-pgsql: sudo -u postgres -- createuser -s esqutest diff --git a/esqueleto.cabal b/esqueleto.cabal index bca865b..07181b3 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -77,7 +77,6 @@ library -Widentities -Wcpp-undef -Wcpp-undef - -Wmonomorphism-restriction default-language: Haskell2010 test-suite specs @@ -100,7 +99,6 @@ test-suite specs build-depends: base >=4.8 && <5.0 , aeson - , postgresql-simple , attoparsec , blaze-html , bytestring @@ -116,8 +114,10 @@ test-suite specs , mysql-simple , persistent , persistent-mysql - , persistent-sqlite , persistent-postgresql + , persistent-sqlite + , postgresql-simple + , QuickCheck , resourcet , tagged , text diff --git a/test/Common/Test.hs b/test/Common/Test.hs index deed118..ae30369 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -32,8 +33,6 @@ module Common.Test , migrateUnique , cleanDB , cleanUniques - , RunDbMonad - , Run , updateRethrowingQuery , selectRethrowingQuery , p1, p2, p3, p4, p5 @@ -67,26 +66,12 @@ module Common.Test import Common.Test.Import hiding (from, on) import Control.Monad (forM_, replicateM, replicateM_, void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Reader (ask) import Data.Either -import Data.Time -#if __GLASGOW_HASKELL__ >= 806 -import Control.Monad.Fail (MonadFail) -#endif -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Logger - (MonadLogger(..), MonadLoggerIO(..), NoLoggingT, runNoLoggingT) -import Control.Monad.Trans.Reader (ReaderT) import qualified Data.Attoparsec.Text as AP import Data.Char (toLower, toUpper) import Data.Monoid ((<>)) import Database.Esqueleto -import Database.Esqueleto.Experimental hiding (from, on) import qualified Database.Esqueleto.Experimental as Experimental -import Database.Persist.TH -import Test.Hspec -import UnliftIO import Data.Conduit (ConduitT, runConduit, (.|)) import qualified Data.Conduit.List as CL @@ -150,8 +135,8 @@ u3 = OneUnique "Third" 0 u4 :: OneUnique u4 = OneUnique "First" 2 -testSubSelect :: Run -> Spec -testSubSelect run = do +testSubSelect :: SpecDb +testSubSelect = do let setup :: MonadIO m => SqlPersistT m () setup = do _ <- insert $ Numbers 1 2 @@ -161,55 +146,55 @@ testSubSelect run = do pure () describe "subSelect" $ do - it "is safe for queries that may return multiple results" $ do + itDb "is safe for queries that may return multiple results" $ do let query = from $ \n -> do orderBy [asc (n ^. NumbersInt)] pure (n ^. NumbersInt) - res <- run $ do - setup - select $ pure $ subSelect query - res `shouldBe` [Value (Just 1)] - - eres <- try $ run $ do - setup + setup + res <- select $ pure $ subSelect query + eres <- try $ do select $ pure $ sub_select query - case eres of - Left (SomeException _) -> - -- We should receive an exception, but the different database - -- libraries throw different exceptions. Hooray. - pure () - Right v -> - -- This shouldn't happen, but in sqlite land, many things are - -- possible. - v `shouldBe` [Value 1] + asserting $ do + res `shouldBe` [Value (Just 1)] + case eres of + Left (SomeException _) -> + -- We should receive an exception, but the different database + -- libraries throw different exceptions. Hooray. + pure () + Right v -> + -- This shouldn't happen, but in sqlite land, many things are + -- possible. + v `shouldBe` [Value 1] - it "is safe for queries that may not return anything" $ do + itDb "is safe for queries that may not return anything" $ do let query = from $ \n -> do orderBy [asc (n ^. NumbersInt)] limit 1 pure (n ^. NumbersInt) - res <- run $ select $ pure $ subSelect query - res `shouldBe` [Value Nothing] + setup + res <- select $ pure $ subSelect query + transactionUndo - eres <- try $ run $ do - setup + eres <- try $ do select $ pure $ sub_select query - case eres of - Left (_ :: PersistException) -> - -- We expect to receive this exception. However, sqlite evidently has - -- no problems with it, so we can't *require* that the exception is - -- thrown. Sigh. - pure () - Right v -> - -- This shouldn't happen, but in sqlite land, many things are - -- possible. - v `shouldBe` [Value 1] + asserting $ do + res `shouldBe` [Value $ Just 1] + case eres of + Left (_ :: PersistException) -> + -- We expect to receive this exception. However, sqlite evidently has + -- no problems with itDb, so we can't *require* that the exception is + -- thrown. Sigh. + pure () + Right v -> + -- This shouldn't happen, but in sqlite land, many things are + -- possible. + v `shouldBe` [Value 1] describe "subSelectList" $ do - it "is safe on empty databases as well as good databases" $ run $ do + itDb "is safe on empty databases as well as good databases" $ do let query = from $ \n -> do where_ $ n ^. NumbersInt `in_` do @@ -224,12 +209,12 @@ testSubSelect run = do setup select query - liftIO $ do + asserting $ do empty `shouldBe` [] full `shouldSatisfy` (not . null) describe "subSelectMaybe" $ do - it "is equivalent to joinV . subSelect" $ do + itDb "is equivalent to joinV . subSelect" $ do let query :: (SqlQuery (SqlExpr (Value (Maybe Int))) -> SqlExpr (Value (Maybe Int))) -> SqlQuery (SqlExpr (Value (Maybe Int))) @@ -241,18 +226,15 @@ testSubSelect run = do where_ $ n' ^. NumbersDouble >=. n ^. NumbersDouble pure (max_ (n' ^. NumbersInt)) - a <- run $ do - setup - select (query subSelectMaybe) - b <- run $ do - setup - select (query (joinV . subSelect)) - a `shouldBe` b + setup + a <- select (query subSelectMaybe) + b <- select (query (joinV . subSelect)) + asserting $ a `shouldBe` b describe "subSelectCount" $ do - it "is a safe way to do a countRows" $ do - xs0 <- run $ do - setup + itDb "is a safe way to do a countRows" $ do + setup + xs0 <- select $ from $ \n -> do pure $ (,) n $ @@ -260,8 +242,7 @@ testSubSelect run = do from $ \n' -> do where_ $ n' ^. NumbersInt >=. n ^. NumbersInt - xs1 <- run $ do - setup + xs1 <- select $ from $ \n -> do pure $ (,) n $ @@ -271,12 +252,13 @@ testSubSelect run = do pure (countRows :: SqlExpr (Value Int)) let getter (Entity _ a, b) = (a, b) - map getter xs0 `shouldBe` map getter xs1 + asserting $ + map getter xs0 `shouldBe` map getter xs1 describe "subSelectUnsafe" $ do - it "throws exceptions on multiple results" $ do - eres <- try $ run $ do - setup + itDb "throws exceptions on multiple results" $ do + setup + eres <- try $ do bad <- select $ from $ \n -> do pure $ (,) (n ^. NumbersInt) $ @@ -290,19 +272,18 @@ testSubSelect run = do from $ \n' -> do pure (n' ^. NumbersDouble) pure (bad, good) - case eres of + asserting $ case eres of Left (SomeException _) -> -- Must use SomeException because the database libraries throw their -- own errors. pure () Right (bad, good) -> do -- SQLite just takes the first element of the sub-select. lol. - -- bad `shouldBe` good - it "throws exceptions on null results" $ do - eres <- try $ run $ do - setup + itDb "throws exceptions on null results" $ do + setup + eres <- try $ do select $ from $ \n -> do pure $ (,) (n ^. NumbersInt) $ @@ -310,34 +291,41 @@ testSubSelect run = do from $ \n' -> do where_ $ val False pure (n' ^. NumbersDouble) - case eres of + asserting $ case eres of Left (_ :: PersistException) -> pure () Right xs -> xs `shouldBe` [] -testSelectSource :: Run -> Spec -testSelectSource run = do +testSelectSource :: SpecDb +testSelectSource = do describe "selectSource" $ do - it "works for a simple example" $ run $ do - let query = selectSource $ - from $ \person -> - return person + itDb "works for a simple example" $ do + let query + :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) () + query = + selectSource $ + from $ \person -> + return person p1e <- insert' p1 - ret <- runConduit $ query .| CL.consume - liftIO $ ret `shouldBe` [ p1e ] + ret <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume + asserting $ ret `shouldBe` [ p1e ] - it "can run a query many times" $ run $ do - let query = selectSource $ - from $ \person -> - return person + itDb "can run a query many times" $ do + let query + :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) () + query = + selectSource $ + from $ \person -> + return person p1e <- insert' p1 - ret0 <- runConduit $ query .| CL.consume - ret1 <- runConduit $ query .| CL.consume - liftIO $ ret0 `shouldBe` [ p1e ] - liftIO $ ret1 `shouldBe` [ p1e ] + ret0 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume + ret1 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume + asserting $ do + ret0 `shouldBe` [ p1e ] + ret1 `shouldBe` [ p1e ] - it "works on repro" $ do + itDb "works on repro" $ do let selectPerson :: R.MonadResource m => String -> ConduitT () (Key Person) (SqlPersistT m) () selectPerson name = do let source = @@ -345,42 +333,41 @@ testSelectSource run = do where_ $ person ^. PersonName ==. val name return $ person ^. PersonId source .| CL.map unValue - run $ do - p1e <- insert' p1 - p2e <- insert' p2 - r1 <- runConduit $ selectPerson (personName p1) .| CL.consume - r2 <- runConduit $ selectPerson (personName p2) .| CL.consume - liftIO $ do - r1 `shouldBe` [ entityKey p1e ] - r2 `shouldBe` [ entityKey p2e ] + p1e <- insert' p1 + p2e <- insert' p2 + r1 <- mapReaderT R.runResourceT $ runConduit $ selectPerson (personName p1) .| CL.consume + r2 <- mapReaderT R.runResourceT $ runConduit $ selectPerson (personName p2) .| CL.consume + asserting $ do + r1 `shouldBe` [ entityKey p1e ] + r2 `shouldBe` [ entityKey p2e ] -testSelectFrom :: Run -> Spec -testSelectFrom run = do +testSelectFrom :: SpecDb +testSelectFrom = do describe "select/from" $ do - it "works for a simple example" $ run $ do + itDb "works for a simple example" $ do p1e <- insert' p1 ret <- select $ from $ \person -> return person - liftIO $ ret `shouldBe` [ p1e ] + asserting $ ret `shouldBe` [ p1e ] - it "works for a simple self-join (one entity)" $ run $ do + itDb "works for a simple self-join (one entity)" $ do p1e <- insert' p1 ret <- select $ from $ \(person1, person2) -> return (person1, person2) - liftIO $ ret `shouldBe` [ (p1e, p1e) ] + asserting $ ret `shouldBe` [ (p1e, p1e) ] - it "works for a simple self-join (two entities)" $ run $ do + itDb "works for a simple self-join (two entities)" $ do p1e <- insert' p1 p2e <- insert' p2 ret <- select $ from $ \(person1, person2) -> return (person1, person2) - liftIO $ + asserting $ ret `shouldSatisfy` sameElementsAs @@ -390,7 +377,7 @@ testSelectFrom run = do , (p2e, p2e) ] - it "works for a self-join via sub_select" $ run $ do + itDb "works for a self-join via sub_select" $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) @@ -403,9 +390,9 @@ testSelectFrom run = do return $ followB ^. FollowFollower where_ $ followA ^. FollowFollowed ==. sub_select subquery return followA - liftIO $ length ret `shouldBe` 2 + asserting $ length ret `shouldBe` 2 - it "works for a self-join via exists" $ run $ do + itDb "works for a self-join via exists" $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) @@ -416,31 +403,31 @@ testSelectFrom run = do from $ \followB -> where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed return followA - liftIO $ length ret `shouldBe` 2 + asserting $ length ret `shouldBe` 2 - it "works for a simple projection" $ run $ do + itDb "works for a simple projection" $ do p1k <- insert p1 p2k <- insert p2 ret <- select $ from $ \p -> return (p ^. PersonId, p ^. PersonName) - liftIO $ ret `shouldBe` [ (Value p1k, Value (personName p1)) + asserting $ ret `shouldBe` [ (Value p1k, Value (personName p1)) , (Value p2k, Value (personName p2)) ] - it "works for a simple projection with a simple implicit self-join" $ run $ do + itDb "works for a simple projection with a simple implicit self-join" $ do _ <- insert p1 _ <- insert p2 ret <- select $ from $ \(pa, pb) -> return (pa ^. PersonName, pb ^. PersonName) - liftIO $ ret `shouldSatisfy` sameElementsAs + asserting $ ret `shouldSatisfy` sameElementsAs [ (Value (personName p1), Value (personName p1)) , (Value (personName p1), Value (personName p2)) , (Value (personName p2), Value (personName p1)) , (Value (personName p2), Value (personName p2)) ] - it "works with many kinds of LIMITs and OFFSETs" $ run $ do + itDb "works with many kinds of LIMITs and OFFSETs" $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] let people = from $ \p -> do @@ -452,21 +439,21 @@ testSelectFrom run = do limit 2 limit 1 return p - liftIO $ ret1 `shouldBe` [ p1e ] + asserting $ ret1 `shouldBe` [ p1e ] ret2 <- select $ do p <- people limit 1 limit 2 return p - liftIO $ ret2 `shouldBe` [ p1e, p4e ] + asserting $ ret2 `shouldBe` [ p1e, p4e ] ret3 <- select $ do p <- people offset 3 offset 2 return p - liftIO $ ret3 `shouldBe` [ p3e, p2e ] + asserting $ ret3 `shouldBe` [ p3e, p2e ] ret4 <- select $ do p <- people @@ -477,7 +464,7 @@ testSelectFrom run = do offset 1 limit 2 return p - liftIO $ ret4 `shouldBe` [ p4e, p3e ] + asserting $ ret4 `shouldBe` [ p4e, p3e ] ret5 <- select $ do p <- people @@ -486,39 +473,39 @@ testSelectFrom run = do limit 1000 offset 0 return p - liftIO $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ] + asserting $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ] - it "works with non-id primary key" $ run $ do + itDb "works with non-id primary key" $ do let fc = Frontcover number "" - number = 101 + number = 101 :: Int Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc [Entity _ ret] <- select $ from return - liftIO $ do + asserting $ do ret `shouldBe` fc fcPk `shouldBe` thePk - it "works when returning a custom non-composite primary key from a query" $ run $ do + itDb "works when returning a custom non-composite primary key from a query" $ do let name = "foo" t = Tag name Right thePk = keyFromValues [toPersistValue name] tagPk <- insert t [Value ret] <- select $ from $ \t' -> return (t'^.TagId) - liftIO $ do + asserting $ do ret `shouldBe` thePk thePk `shouldBe` tagPk - it "works when returning a composite primary key from a query" $ run $ do + itDb "works when returning a composite primary key from a query" $ do let p = Point 10 20 "" thePk <- insert p [Value ppk] <- select $ from $ \p' -> return (p'^.PointId) - liftIO $ ppk `shouldBe` thePk + asserting $ ppk `shouldBe` thePk -testSelectJoin :: Run -> Spec -testSelectJoin run = do +testSelectJoin :: SpecDb +testSelectJoin = do describe "select:JOIN" $ do - it "works with a LEFT OUTER JOIN" $ - run $ do + itDb "works with a LEFT OUTER JOIN" $ + do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 @@ -531,47 +518,50 @@ testSelectJoin run = do on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] return (p, mb) - liftIO $ ret `shouldBe` [ (p1e, Just b11e) + asserting $ ret `shouldBe` [ (p1e, Just b11e) , (p1e, Just b12e) , (p4e, Nothing) , (p3e, Just b31e) , (p2e, Nothing) ] - it "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $ - let _ = run $ - select $ - from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) -> - let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] - in return a - in return () :: IO () + itDb "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $ + let + _x :: SqlPersistT IO _ + _x = + select $ + from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) -> + let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] + in return a + in asserting noExceptions - it "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $ - let _ = run $ - select $ - from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) -> - let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] - in return a - in return () :: IO () + itDb "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $ + let _x :: SqlPersistT IO _ + _x = + select $ + from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) -> + let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] + in return a + in asserting noExceptions - it "throws an error for using on without joins" $ - run (select $ - from $ \(p, mb) -> do + itDb "throws an error for using on without joins" $ do + eres <- try $ select $ + from $ \(p, mb) -> do on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] return (p, mb) - ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True) + asserting $ shouldBeOnClauseWithoutMatchingJoinException eres - it "throws an error for using too many ons" $ - run (select $ + itDb "throws an error for using too many ons" $ do + eres <- try $ select $ from $ \(p `FullOuterJoin` mb) -> do on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] return (p, mb) - ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True) + asserting $ shouldBeOnClauseWithoutMatchingJoinException eres - it "works with ForeignKey to a non-id primary key returning one entity" $ - run $ do + itDb "works with ForeignKey to a non-id primary key returning one entity" $ + do let fc = Frontcover number "" article = Article "Esqueleto supports composite pks!" number number = 101 @@ -582,11 +572,11 @@ testSelectJoin run = do from $ \(a `InnerJoin` f) -> do on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) return f - liftIO $ do + asserting $ do retFc `shouldBe` fc fcPk `shouldBe` thePk - it "allows using a primary key that is itself a key of another table" $ - run $ do + itDb "allows using a primary key that is itself a key of another table" $ + do let number = 101 insert_ $ Frontcover number "" articleId <- insert $ Article "title" number @@ -594,9 +584,9 @@ testSelectJoin run = do result <- select $ from $ \articleMetadata -> do where_ $ (articleMetadata ^. ArticleMetadataId) ==. (val ((ArticleMetadataKey articleId))) pure articleMetadata - liftIO $ [articleMetaE] `shouldBe` result - it "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do - run $ do + asserting $ [articleMetaE] `shouldBe` result + itDb "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do + do let number = 101 insert_ $ Frontcover number "" articleE@(Entity articleId _) <- insert' $ Article "title" number @@ -606,10 +596,10 @@ testSelectJoin run = do from $ \(article `InnerJoin` articleMetadata) -> do on (toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId) return (article, articleMetadata) - liftIO $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata + asserting $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata - it "works with a ForeignKey to a non-id primary key returning both entities" $ - run $ do + itDb "works with a ForeignKey to a non-id primary key returning both entities" $ + do let fc = Frontcover number "" article = Article "Esqueleto supports composite pks!" number number = 101 @@ -620,14 +610,14 @@ testSelectJoin run = do from $ \(a `InnerJoin` f) -> do on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) return (f, a) - liftIO $ do + asserting $ do retFc `shouldBe` fc retArt `shouldBe` article fcPk `shouldBe` thePk articleFkfrontcover retArt `shouldBe` thePk - it "works with a non-id primary key returning one entity" $ - run $ do + itDb "works with a non-id primary key returning one entity" $ + do let fc = Frontcover number "" article = Article2 "Esqueleto supports composite pks!" thePk number = 101 @@ -638,14 +628,14 @@ testSelectJoin run = do from $ \(a `InnerJoin` f) -> do on (f^.FrontcoverId ==. a^.Article2FrontcoverId) return f - liftIO $ do + asserting $ do retFc `shouldBe` fc fcPk `shouldBe` thePk - it "works with a composite primary key" $ + it "works with a composite primary key" $ \_ -> pendingWith "Persistent does not create the CircleFkPoint constructor. See: https://github.com/yesodweb/persistent/issues/341" {- - run $ do + do let p = Point x y "" c = Circle x y "" x = 10 @@ -656,13 +646,13 @@ testSelectJoin run = do [Entity _ ret] <- select $ from $ \(c' `InnerJoin` p') -> do on (p'^.PointId ==. c'^.CircleFkpoint) return p' - liftIO $ do + asserting $ do ret `shouldBe` p pPk `shouldBe` thePk -} - it "works when joining via a non-id primary key" $ - run $ do + itDb "works when joining via a non-id primary key" $ + do let fc = Frontcover number "" article = Article "Esqueleto supports composite pks!" number tag = Tag "foo" @@ -678,12 +668,12 @@ testSelectJoin run = do on (t^.TagId ==. at^.ArticleTagTagId) on (a^.ArticleId ==. at^.ArticleTagArticleId) return (a, t) - liftIO $ do + asserting $ do retArt `shouldBe` article retTag `shouldBe` tag - it "respects the associativity of joins" $ - run $ do + itDb "respects the associativity of joins" $ + do void $ insert p1 ps <- select $ from $ \((p :: SqlExpr (Entity Person)) @@ -693,19 +683,19 @@ testSelectJoin run = do on (val False) -- Inner join is empty on (val True) return p - liftIO $ (entityVal <$> ps) `shouldBe` [p1] + asserting $ (entityVal <$> ps) `shouldBe` [p1] -testSelectSubQuery :: Run -> Spec -testSelectSubQuery run = describe "select subquery" $ do - it "works" $ run $ do +testSelectSubQuery :: SpecDb +testSelectSubQuery = describe "select subquery" $ do + itDb "works" $ do _ <- insert' p1 let q = do p <- Experimental.from $ Table @Person return ( p ^. PersonName, p ^. PersonAge) ret <- select $ Experimental.from q - liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] + asserting $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] - it "supports sub-selecting Maybe entities" $ run $ do + itDb "supports sub-selecting Maybe entities" $ do l1e <- insert' l1 l3e <- insert' l3 l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int]) @@ -719,9 +709,9 @@ testSelectSubQuery run = describe "select subquery" $ do pure (lords, deeds) ret <- select q - liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds) + asserting $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds) - it "lets you order by alias" $ run $ do + itDb "lets you order by alias" $ do _ <- insert' p1 _ <- insert' p3 let q = do @@ -732,9 +722,9 @@ testSelectSubQuery run = describe "select subquery" $ do orderBy [ asc age ] pure name ret <- select q - liftIO $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ] + asserting $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ] - it "supports groupBy" $ run $ do + itDb "supports groupBy" $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) @@ -752,10 +742,10 @@ testSelectSubQuery run = describe "select subquery" $ do return (lordId, count deedId) (ret :: [(Value (Key Lord), Value Int)]) <- select q' - liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7) + asserting $ ret `shouldMatchList` [ (Value l3k, Value 7) , (Value l1k, Value 3) ] - it "Can count results of aggregate query" $ run $ do + itDb "Can count results of aggregate query" $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) @@ -774,9 +764,9 @@ testSelectSubQuery run = describe "select subquery" $ do where_ $ deedCount >. val (3 :: Int) return (count lordId) - liftIO $ ret `shouldMatchList` [ (Value 1) ] + asserting $ ret `shouldMatchList` [ (Value 1) ] - it "joins on subqueries" $ run $ do + itDb "joins on subqueries" $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) @@ -790,10 +780,10 @@ testSelectSubQuery run = describe "select subquery" $ do groupBy (lord ^. LordId) return (lord ^. LordId, count (deed ^. DeedId)) (ret :: [(Value (Key Lord), Value Int)]) <- select q - liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7) + asserting $ ret `shouldMatchList` [ (Value l3k, Value 7) , (Value l1k, Value 3) ] - it "flattens maybe values" $ run $ do + itDb "flattens maybe values" $ do l1k <- insert l1 l3k <- insert l3 let q = do @@ -806,9 +796,9 @@ testSelectSubQuery run = describe "select subquery" $ do groupBy (lord ^. LordId, dogCounts) return (lord ^. LordId, dogCounts) (ret :: [(Value (Key Lord), Value (Maybe Int))]) <- select q - liftIO $ ret `shouldMatchList` [ (Value l3k, Value (lordDogs l3)) + asserting $ ret `shouldMatchList` [ (Value l3k, Value (lordDogs l3)) , (Value l1k, Value (lordDogs l1)) ] - it "unions" $ run $ do + itDb "unions" $ do _ <- insert p1 _ <- insert p2 let q = Experimental.from $ @@ -827,11 +817,11 @@ testSelectSubQuery run = describe "select subquery" $ do where_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) names <- select q - liftIO $ names `shouldMatchList` [ (Value $ personName p1) + asserting $ names `shouldMatchList` [ (Value $ personName p1) , (Value $ personName p2) ] -testSelectWhere :: Run -> Spec -testSelectWhere run = describe "select where_" $ do - it "works for a simple example with (==.)" $ run $ do +testSelectWhere :: SpecDb +testSelectWhere = describe "select where_" $ do + itDb "works for a simple example with (==.)" $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 @@ -839,9 +829,9 @@ testSelectWhere run = describe "select where_" $ do from $ \p -> do where_ (p ^. PersonName ==. val "John") return p - liftIO $ ret `shouldBe` [ p1e ] + asserting $ ret `shouldBe` [ p1e ] - it "works for a simple example with (==.) and (||.)" $ run $ do + itDb "works for a simple example with (==.) and (||.)" $ do p1e <- insert' p1 p2e <- insert' p2 _ <- insert' p3 @@ -849,9 +839,9 @@ testSelectWhere run = describe "select where_" $ do from $ \p -> do where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel") return p - liftIO $ ret `shouldBe` [ p1e, p2e ] + asserting $ ret `shouldBe` [ p1e, p2e ] - it "works for a simple example with (>.) [uses val . Just]" $ run $ do + itDb "works for a simple example with (>.) [uses val . Just]" $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 @@ -859,9 +849,9 @@ testSelectWhere run = describe "select where_" $ do from $ \p -> do where_ (p ^. PersonAge >. val (Just 17)) return p - liftIO $ ret `shouldBe` [ p1e ] + asserting $ ret `shouldBe` [ p1e ] - it "works for a simple example with (>.) and not_ [uses just . val]" $ run $ do + itDb "works for a simple example with (>.) and not_ [uses just . val]" $ do _ <- insert' p1 _ <- insert' p2 p3e <- insert' p3 @@ -869,10 +859,10 @@ testSelectWhere run = describe "select where_" $ do from $ \p -> do where_ (not_ $ p ^. PersonAge >. just (val 17)) return p - liftIO $ ret `shouldBe` [ p3e ] + asserting $ ret `shouldBe` [ p3e ] describe "when using between" $ do - it "works for a simple example with [uses just . val]" $ run $ do + itDb "works for a simple example with [uses just . val]" $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 @@ -880,8 +870,8 @@ testSelectWhere run = describe "select where_" $ do from $ \p -> do where_ ((p ^. PersonAge) `between` (just $ val 20, just $ val 40)) return p - liftIO $ ret `shouldBe` [ p1e ] - it "works for a proyected fields value" $ run $ do + asserting $ ret `shouldBe` [ p1e ] + itDb "works for a proyected fields value" $ do _ <- insert' p1 >> insert' p2 >> insert' p3 ret <- select $ @@ -890,9 +880,9 @@ testSelectWhere run = describe "select where_" $ do just (p ^. PersonFavNum) `between` (p ^. PersonAge, p ^. PersonWeight) - liftIO $ ret `shouldBe` [] + asserting $ ret `shouldBe` [] describe "when projecting composite keys" $ do - it "works when using composite keys with val" $ run $ do + itDb "works when using composite keys with val" $ do insert_ $ Point 1 2 "" ret <- select $ @@ -902,9 +892,9 @@ testSelectWhere run = describe "select where_" $ do `between` ( val $ PointKey 1 2 , val $ PointKey 5 6 ) - liftIO $ ret `shouldBe` [()] + asserting $ ret `shouldBe` [()] - it "works with avg_" $ run $ do + itDb "works with avg_" $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 @@ -917,10 +907,10 @@ testSelectWhere run = describe "select where_" $ do retV :: [Value (Maybe Double)] retV = map (Value . fmap (roundTo (4 :: Integer)) . unValue) (ret :: [Value (Maybe Double)]) - liftIO $ retV `shouldBe` [ Value $ Just testV ] + asserting $ retV `shouldBe` [ Value $ Just testV ] - it "works with min_" $ - run $ do + itDb "works with min_" $ + do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 @@ -928,9 +918,9 @@ testSelectWhere run = describe "select where_" $ do ret <- select $ from $ \p-> return $ joinV $ min_ (p ^. PersonAge) - liftIO $ ret `shouldBe` [ Value $ Just (17 :: Int) ] + asserting $ ret `shouldBe` [ Value $ Just (17 :: Int) ] - it "works with max_" $ run $ do + itDb "works with max_" $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 @@ -938,9 +928,9 @@ testSelectWhere run = describe "select where_" $ do ret <- select $ from $ \p-> return $ joinV $ max_ (p ^. PersonAge) - liftIO $ ret `shouldBe` [ Value $ Just (36 :: Int) ] + asserting $ ret `shouldBe` [ Value $ Just (36 :: Int) ] - it "works with lower_" $ run $ do + itDb "works with lower_" $ do p1e <- insert' p1 p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1 @@ -949,20 +939,20 @@ testSelectWhere run = describe "select where_" $ do from $ \p-> do where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1)) return p - liftIO $ ret1 `shouldBe` [ p1e ] + asserting $ ret1 `shouldBe` [ p1e ] -- name == lower('BOB') ret2 <- select $ from $ \p-> do where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob)) return p - liftIO $ ret2 `shouldBe` [ p2e ] + asserting $ ret2 `shouldBe` [ p2e ] - it "works with round_" $ run $ do + itDb "works with round_" $ do ret <- select $ return $ round_ (val (16.2 :: Double)) - liftIO $ ret `shouldBe` [ Value (16 :: Double) ] + asserting $ ret `shouldBe` [ Value (16 :: Double) ] - it "works with isNothing" $ run $ do + itDb "works with isNothing" $ do _ <- insert' p1 p2e <- insert' p2 _ <- insert' p3 @@ -970,19 +960,19 @@ testSelectWhere run = describe "select where_" $ do from $ \p -> do where_ $ isNothing (p ^. PersonAge) return p - liftIO $ ret `shouldBe` [ p2e ] + asserting $ ret `shouldBe` [ p2e ] - it "works with not_ . isNothing" $ run $ do + itDb "works with not_ . isNothing" $ do p1e <- insert' p1 _ <- insert' p2 ret <- select $ from $ \p -> do where_ $ not_ (isNothing (p ^. PersonAge)) return p - liftIO $ ret `shouldBe` [ p1e ] + asserting $ ret `shouldBe` [ p1e ] - it "works for a many-to-many implicit join" $ - run $ do + itDb "works for a many-to-many implicit join" $ + do p1e@(Entity p1k _) <- insert' p1 p2e@(Entity p2k _) <- insert' p2 _ <- insert' p3 @@ -998,12 +988,12 @@ testSelectWhere run = describe "select where_" $ do orderBy [ asc (follower ^. PersonName) , asc (followed ^. PersonName) ] return (follower, follows, followed) - liftIO $ ret `shouldBe` [ (p1e, f11, p1e) + asserting $ ret `shouldBe` [ (p1e, f11, p1e) , (p1e, f12, p2e) , (p4e, f42, p2e) , (p2e, f21, p1e) ] - it "works for a many-to-many explicit join" $ run $ do + itDb "works for a many-to-many explicit join" $ do p1e@(Entity p1k _) <- insert' p1 p2e@(Entity p2k _) <- insert' p2 _ <- insert' p3 @@ -1019,13 +1009,13 @@ testSelectWhere run = describe "select where_" $ do orderBy [ asc (follower ^. PersonName) , asc (followed ^. PersonName) ] return (follower, follows, followed) - liftIO $ ret `shouldBe` [ (p1e, f11, p1e) + asserting $ ret `shouldBe` [ (p1e, f11, p1e) , (p1e, f12, p2e) , (p4e, f42, p2e) , (p2e, f21, p1e) ] - it "works for a many-to-many explicit join and on order doesn't matter" $ do - run $ void $ + itDb "works for a many-to-many explicit join and on order doesn't matter" $ do + void $ selectRethrowingQuery $ from $ \(person `InnerJoin` blog `InnerJoin` comment) -> do on $ person ^. PersonId ==. blog ^. BlogPostAuthorId @@ -1033,9 +1023,9 @@ testSelectWhere run = describe "select where_" $ do pure (person, comment) -- we only care that we don't have a SQL error - True `shouldBe` True + asserting noExceptions - it "works for a many-to-many explicit join with LEFT OUTER JOINs" $ run $ do + itDb "works for a many-to-many explicit join with LEFT OUTER JOINs" $ do p1e@(Entity p1k _) <- insert' p1 p2e@(Entity p2k _) <- insert' p2 p3e <- insert' p3 @@ -1051,13 +1041,13 @@ testSelectWhere run = describe "select where_" $ do orderBy [ asc ( follower ^. PersonName) , asc (mfollowed ?. PersonName) ] return (follower, mfollows, mfollowed) - liftIO $ ret `shouldBe` [ (p1e, Just f11, Just p1e) + asserting $ ret `shouldBe` [ (p1e, Just f11, Just p1e) , (p1e, Just f12, Just p2e) , (p4e, Just f42, Just p2e) , (p3e, Nothing, Nothing) , (p2e, Just f21, Just p1e) ] - it "works with a composite primary key" $ run $ do + itDb "works with a composite primary key" $ do let p = Point x y "" x = 10 y = 15 @@ -1066,13 +1056,13 @@ testSelectWhere run = describe "select where_" $ do [Entity _ ret] <- select $ from $ \p' -> do where_ (p'^.PointId ==. val pPk) return p' - liftIO $ do + asserting $ do ret `shouldBe` p pPk `shouldBe` thePk -testSelectOrderBy :: Run -> Spec -testSelectOrderBy run = describe "select/orderBy" $ do - it "works with a single ASC field" $ run $ do +testSelectOrderBy :: SpecDb +testSelectOrderBy = describe "select/orderBy" $ do + itDb "works with a single ASC field" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 @@ -1080,9 +1070,9 @@ testSelectOrderBy run = describe "select/orderBy" $ do from $ \p -> do orderBy [asc $ p ^. PersonName] return p - liftIO $ ret `shouldBe` [ p1e, p3e, p2e ] + asserting $ ret `shouldBe` [ p1e, p3e, p2e ] - it "works with a sub_select" $ run $ do + itDb "works with a sub_select" $ do [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4] [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k] ret <- select $ @@ -1093,20 +1083,20 @@ testSelectOrderBy run = describe "select/orderBy" $ do return (p ^. PersonName) ] return (b ^. BlogPostId) - liftIO $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k]) + asserting $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k]) - it "works on a composite primary key" $ run $ do + itDb "works on a composite primary key" $ do let ps = [Point 2 1 "", Point 1 2 ""] mapM_ insert ps eps <- select $ from $ \p' -> do orderBy [asc (p'^.PointId)] return p' - liftIO $ map entityVal eps `shouldBe` reverse ps + asserting $ map entityVal eps `shouldBe` reverse ps -testAscRandom :: SqlExpr (Value Double) -> Run -> Spec -testAscRandom rand' run = describe "random_" $ - it "asc random_ works" $ run $ do +testAscRandom :: SqlExpr (Value Double) -> SpecDb +testAscRandom rand' = describe "random_" $ + itDb "asc random_ works" $ do _p1e <- insert' p1 _p2e <- insert' p2 _p3e <- insert' p3 @@ -1121,17 +1111,18 @@ testAscRandom rand' run = describe "random_" $ -- There are 2^4 = 16 possible orderings. The chance -- of 11 random samplings returning the same ordering -- is 1/2^40, so this test should pass almost everytime. - liftIO $ S.size rets `shouldSatisfy` (>2) + asserting $ S.size rets `shouldSatisfy` (>2) -testSelectDistinct :: Run -> Spec -testSelectDistinct run = do +testSelectDistinct :: SpecDb +testSelectDistinct = do describe "SELECT DISTINCT" $ do let selDistTest - :: ( forall m. RunDbMonad m - => SqlQuery (SqlExpr (Value String)) - -> SqlPersistT (R.ResourceT m) [Value String]) - -> IO () - selDistTest q = run $ do + :: + ( SqlQuery (SqlExpr (Value String)) + -> SqlPersistT IO [Value String] + ) + -> SqlPersistT IO () + selDistTest q = do p1k <- insert p1 let (t1, t2, t3) = ("a", "b", "c") mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1] @@ -1140,25 +1131,25 @@ testSelectDistinct run = do let title = b ^. BlogPostTitle orderBy [asc title] return title - liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ] + asserting $ ret `shouldBe` [ Value t1, Value t2, Value t3 ] - it "works on a simple example (select . distinct)" $ + itDb "works on a simple example (select . distinct)" $ selDistTest (\a -> select $ distinct a) - it "works on a simple example (distinct (return ()))" $ + itDb "works on a simple example (distinct (return ()))" $ selDistTest (\act -> select $ distinct (return ()) >> act) -testCoasleceDefault :: Run -> Spec -testCoasleceDefault run = describe "coalesce/coalesceDefault" $ do - it "works on a simple example" $ run $ do +testCoasleceDefault :: SpecDb +testCoasleceDefault = describe "coalesce/coalesceDefault" $ do + itDb "works on a simple example" $ do mapM_ insert' [p1, p2, p3, p4, p5] ret1 <- select $ from $ \p -> do orderBy [asc (p ^. PersonId)] return (coalesce [p ^. PersonAge, p ^. PersonWeight]) - liftIO $ ret1 `shouldBe` [ Value (Just (36 :: Int)) + asserting $ ret1 `shouldBe` [ Value (Just (36 :: Int)) , Value (Just 37) , Value (Just 17) , Value (Just 17) @@ -1169,14 +1160,14 @@ testCoasleceDefault run = describe "coalesce/coalesceDefault" $ do from $ \p -> do orderBy [asc (p ^. PersonId)] return (coalesceDefault [p ^. PersonAge, p ^. PersonWeight] (p ^. PersonFavNum)) - liftIO $ ret2 `shouldBe` [ Value (36 :: Int) + asserting $ ret2 `shouldBe` [ Value (36 :: Int) , Value 37 , Value 17 , Value 17 , Value 5 ] - it "works with sub-queries" $ run $ do + itDb "works with sub-queries" $ do p1id <- insert p1 p2id <- insert p2 p3id <- insert p3 @@ -1192,15 +1183,15 @@ testCoasleceDefault run = describe "coalesce/coalesceDefault" $ do where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) return $ p ^. PersonAge return $ coalesceDefault [sub_select sub] (val (42 :: Int)) - liftIO $ ret `shouldBe` [ Value (36 :: Int) + asserting $ ret `shouldBe` [ Value (36 :: Int) , Value 42 , Value 17 ] -testDelete :: Run -> Spec -testDelete run = describe "delete" $ do - it "works on a simple example" $ run $ do +testDelete :: SpecDb +testDelete = describe "delete" $ do + itDb "works on a simple example" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 @@ -1209,21 +1200,21 @@ testDelete run = describe "delete" $ do orderBy [asc (p ^. PersonName)] return p ret1 <- getAll - liftIO $ ret1 `shouldBe` [ p1e, p3e, p2e ] + asserting $ ret1 `shouldBe` [ p1e, p3e, p2e ] () <- delete $ from $ \p -> where_ (p ^. PersonName ==. val (personName p1)) ret2 <- getAll - liftIO $ ret2 `shouldBe` [ p3e, p2e ] + asserting $ ret2 `shouldBe` [ p3e, p2e ] n <- deleteCount $ from $ \p -> return ((p :: SqlExpr (Entity Person)) `seq` ()) ret3 <- getAll - liftIO $ (n, ret3) `shouldBe` (2, []) + asserting $ (n, ret3) `shouldBe` (2, []) -testUpdate :: Run -> Spec -testUpdate run = describe "update" $ do - it "works with a subexpression having COUNT(*)" $ run $ do +testUpdate :: SpecDb +testUpdate = describe "update" $ do + itDb "works with a subexpression having COUNT(*)" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 @@ -1239,14 +1230,14 @@ testUpdate run = describe "update" $ do from $ \p -> do orderBy [ asc (p ^. PersonName) ] return p - liftIO $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 } + asserting $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 } , Entity p3k p3 { personAge = Just 7 } , Entity p2k p2 { personAge = Just 0 } ] - it "works with a composite primary key" $ + it "works with a composite primary key" $ \_ -> pendingWith "Need refactor to support composite pks on ESet" {- - run $ do + do let p = Point x y "" x = 10 y = 15 @@ -1257,11 +1248,11 @@ testUpdate run = describe "update" $ do () <- update $ \p' -> do set p' [PointId =. val newPk] [Entity _ ret] <- select $ from $ return - liftIO $ do + asserting $ do ret `shouldBe` Point newX newY [] -} - it "GROUP BY works with COUNT" $ run $ do + itDb "GROUP BY works with COUNT" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 @@ -1274,11 +1265,11 @@ testUpdate run = describe "update" $ do let cnt = count (b ^. BlogPostId) orderBy [ asc cnt ] return (p, cnt) - liftIO $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int)) + asserting $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int)) , (Entity p1k p1, Value 3) , (Entity p3k p3, Value 7) ] - it "GROUP BY works with composite primary key" $ run $ do + itDb "GROUP BY works with composite primary key" $ do p1k <- insert $ Point 1 2 "asdf" p2k <- insert $ Point 2 3 "asdf" ret <- @@ -1287,13 +1278,13 @@ testUpdate run = describe "update" $ do where_ $ point ^. PointName ==. val "asdf" groupBy (point ^. PointId) pure (point ^. PointId) - liftIO $ do + asserting $ do ret `shouldMatchList` map Value [p1k, p2k] - it "GROUP BY works with COUNT and InnerJoin" $ run $ do + itDb "GROUP BY works with COUNT and InnerJoin" $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) @@ -1305,10 +1296,10 @@ testUpdate run = describe "update" $ do on $ lord ^. LordId ==. deed ^. DeedOwnerId groupBy (lord ^. LordId) return (lord ^. LordId, count $ deed ^. DeedId) - liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7) + asserting $ ret `shouldMatchList` [ (Value l3k, Value 7) , (Value l1k, Value 3) ] - it "GROUP BY works with nested tuples" $ run $ do + itDb "GROUP BY works with nested tuples" $ do l1k <- insert l1 l3k <- insert l3 mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) @@ -1320,9 +1311,9 @@ testUpdate run = describe "update" $ do on $ lord ^. LordId ==. deed ^. DeedOwnerId groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract) return (lord ^. LordId, count $ deed ^. DeedId) - liftIO $ length ret `shouldBe` 10 + asserting $ length ret `shouldBe` 10 - it "GROUP BY works with HAVING" $ run $ do + itDb "GROUP BY works with HAVING" $ do p1k <- insert p1 _p2k <- insert p2 p3k <- insert p3 @@ -1336,7 +1327,7 @@ testUpdate run = describe "update" $ do having (cnt >. (val 0)) orderBy [ asc cnt ] return (p, cnt) - liftIO $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int)) + asserting $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int)) , (Entity p3k p3, Value 7) ] -- we only care that this compiles. check that SqlWriteT doesn't fail on @@ -1365,9 +1356,9 @@ testSqlReadT = groupBy (lord ^. LordId) return (lord ^. LordId, count $ deed ^. DeedId) -testListOfValues :: Run -> Spec -testListOfValues run = describe "lists of values" $ do - it "IN works for valList" $ run $ do +testListOfValues :: SpecDb +testListOfValues = describe "lists of values" $ do + itDb "IN works for valList" $ do p1k <- insert p1 p2k <- insert p2 _p3k <- insert p3 @@ -1375,10 +1366,10 @@ testListOfValues run = describe "lists of values" $ do from $ \p -> do where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2])) return p - liftIO $ ret `shouldBe` [ Entity p1k p1 + asserting $ ret `shouldBe` [ Entity p1k p1 , Entity p2k p2 ] - it "IN works for valList (null list)" $ run $ do + itDb "IN works for valList (null list)" $ do _p1k <- insert p1 _p2k <- insert p2 _p3k <- insert p3 @@ -1386,9 +1377,9 @@ testListOfValues run = describe "lists of values" $ do from $ \p -> do where_ (p ^. PersonName `in_` valList []) return p - liftIO $ ret `shouldBe` [] + asserting $ ret `shouldBe` [] - it "IN works for subList_select" $ run $ do + itDb "IN works for subList_select" $ do p1k <- insert p1 _p2k <- insert p2 p3k <- insert p3 @@ -1402,9 +1393,9 @@ testListOfValues run = describe "lists of values" $ do return (bp ^. BlogPostAuthorId) where_ (p ^. PersonId `in_` subList_select subquery) return p - liftIO $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3] + asserting $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3] - it "NOT IN works for subList_select" $ run $ do + itDb "NOT IN works for subList_select" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 @@ -1417,9 +1408,9 @@ testListOfValues run = describe "lists of values" $ do return (bp ^. BlogPostAuthorId) where_ (p ^. PersonId `notIn` subList_select subquery) return p - liftIO $ ret `shouldBe` [ Entity p2k p2 ] + asserting $ ret `shouldBe` [ Entity p2k p2 ] - it "EXISTS works for subList_select" $ run $ do + itDb "EXISTS works for subList_select" $ do p1k <- insert p1 _p2k <- insert p2 p3k <- insert p3 @@ -1432,10 +1423,10 @@ testListOfValues run = describe "lists of values" $ do where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) orderBy [asc (p ^. PersonName)] return p - liftIO $ ret `shouldBe` [ Entity p1k p1 + asserting $ ret `shouldBe` [ Entity p1k p1 , Entity p3k p3 ] - it "EXISTS works for subList_select" $ run $ do + itDb "EXISTS works for subList_select" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 @@ -1447,55 +1438,56 @@ testListOfValues run = describe "lists of values" $ do from $ \bp -> do where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) return p - liftIO $ ret `shouldBe` [ Entity p2k p2 ] + asserting $ ret `shouldBe` [ Entity p2k p2 ] -testListFields :: Run -> Spec -testListFields run = describe "list fields" $ do +testListFields :: SpecDb +testListFields = describe "list fields" $ do -- - it "can update list fields" $ run $ do + itDb "can update list fields" $ do cclist <- insert $ CcList [] update $ \p -> do set p [ CcListNames =. val ["fred"]] where_ (p ^. CcListId ==. val cclist) + asserting noExceptions -testInsertsBySelect :: Run -> Spec -testInsertsBySelect run = do +testInsertsBySelect :: SpecDb +testInsertsBySelect = do describe "inserts by select" $ do - it "IN works for insertSelect" $ - run $ do + itDb "IN works for insertSelect" $ + do _ <- insert p1 _ <- insert p2 _ <- insert p3 insertSelect $ from $ \p -> do return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows) - liftIO $ ret `shouldBe` [Value (3::Int)] + asserting $ ret `shouldBe` [Value (3::Int)] -testInsertsBySelectReturnsCount :: Run -> Spec -testInsertsBySelectReturnsCount run = do +testInsertsBySelectReturnsCount :: SpecDb +testInsertsBySelectReturnsCount = do describe "inserts by select, returns count" $ do - it "IN works for insertSelectCount" $ - run $ do + itDb "IN works for insertSelectCount" $ + do _ <- insert p1 _ <- insert p2 _ <- insert p3 cnt <- insertSelectCount $ from $ \p -> do return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows) - liftIO $ ret `shouldBe` [Value (3::Int)] - liftIO $ cnt `shouldBe` 3 + asserting $ ret `shouldBe` [Value (3::Int)] + asserting $ cnt `shouldBe` 3 -testRandomMath :: Run -> Spec -testRandomMath run = describe "random_ math" $ - it "rand returns result in random order" $ - run $ do +testRandomMath :: SpecDb +testRandomMath = describe "random_ math" $ + itDb "rand returns result in random order" $ + do replicateM_ 20 $ do _ <- insert p1 _ <- insert p2 @@ -1512,13 +1504,13 @@ testRandomMath run = describe "random_ math" $ orderBy [rand] return (p ^. PersonId) - liftIO $ (ret1 == ret2) `shouldBe` False + asserting $ (ret1 == ret2) `shouldBe` False -testMathFunctions :: Run -> Spec -testMathFunctions run = do +testMathFunctions :: SpecDb +testMathFunctions = do describe "Math-related functions" $ do - it "castNum works for multiplying Int and Double" $ - run $ do + itDb "castNum works for multiplying Int and Double" $ + do mapM_ insert [Numbers 2 3.4, Numbers 7 1.1] ret <- select $ @@ -1526,39 +1518,39 @@ testMathFunctions run = do let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble orderBy [asc r] return r - liftIO $ length ret `shouldBe` 2 + asserting $ length ret `shouldBe` 2 let [Value a, Value b] = ret - liftIO $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01) + asserting $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01) -testCase :: Run -> Spec -testCase run = do +testCase :: SpecDb +testCase = do describe "case" $ do - it "Works for a simple value based when - False" $ - run $ do + itDb "Works for a simple value based when - False" $ + do ret <- select $ return $ case_ [ when_ (val False) then_ (val (1 :: Int)) ] (else_ (val 2)) - liftIO $ ret `shouldBe` [ Value 2 ] + asserting $ ret `shouldBe` [ Value 2 ] - it "Works for a simple value based when - True" $ - run $ do + itDb "Works for a simple value based when - True" $ + do ret <- select $ return $ case_ [ when_ (val True) then_ (val (1 :: Int)) ] (else_ (val 2)) - liftIO $ ret `shouldBe` [ Value 1 ] + asserting $ ret `shouldBe` [ Value 1 ] - it "works for a semi-complicated query" $ - run $ do + itDb "works for a semi-complicated query" $ + do _ <- insert p1 _ <- insert p2 _ <- insert p3 @@ -1580,14 +1572,14 @@ testCase run = do return $ count (v ^. PersonName) +. val (1 :: Int)) ] (else_ $ val (-1)) - liftIO $ ret `shouldBe` [ Value (3) ] + asserting $ ret `shouldBe` [ Value (3) ] -testLocking :: WithConn (NoLoggingT IO) [TL.Text] -> Spec -testLocking withConn = do +testLocking :: SpecDb +testLocking = do describe "locking" $ do -- The locking clause is the last one, so try to use many -- others to test if it's at the right position. We don't @@ -1620,31 +1612,33 @@ testLocking withConn = do toText conn q = let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q in TLB.toLazyText tlb + conn <- ask [complex, with1, with2, with3] <- - runNoLoggingT $ withConn $ \conn -> return $ + return $ map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3] let expected = complex <> "\n" <> syntax - (with1, with2, with3) `shouldBe` (expected, expected, expected) + asserting $ + (with1, with2, with3) `shouldBe` (expected, expected, expected) - it "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" - it "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" - it "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" - it "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE" + itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" + itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" + itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" + itDb "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE" -testCountingRows :: Run -> Spec -testCountingRows run = do +testCountingRows :: SpecDb +testCountingRows = do describe "counting rows" $ do forM_ [ ("count (test A)", count . (^. PersonAge), 4) , ("count (test B)", count . (^. PersonWeight), 5) , ("countRows", const countRows, 5) , ("countDistinct", countDistinct . (^. PersonAge), 2) ] $ \(title, countKind, expected) -> - it (title ++ " works as expected") $ - run $ do + itDb (title ++ " works as expected") $ + do mapM_ insert [ Person "" (Just 1) (Just 1) 1 , Person "" (Just 2) (Just 1) 1 @@ -1652,50 +1646,53 @@ testCountingRows run = do , Person "" (Just 2) (Just 2) 1 , Person "" Nothing (Just 3) 1] [Value n] <- select $ from $ return . countKind - liftIO $ (n :: Int) `shouldBe` expected + asserting $ (n :: Int) `shouldBe` expected -testRenderSql :: Run -> Spec -testRenderSql run = do +testRenderSql :: SpecDb +testRenderSql = do describe "testRenderSql" $ do - it "works" $ do - (queryText, queryVals) <- run $ renderQuerySelect $ + itDb "works" $ do + (queryText, queryVals) <- renderQuerySelect $ from $ \p -> do where_ $ p ^. PersonName ==. val "Johhny Depp" pure (p ^. PersonName, p ^. PersonAge) -- the different backends use different quote marks, so I filter them out -- here instead of making a duplicate test - Text.filter (\c -> c `notElem` ['`', '"']) queryText - `shouldBe` - Text.unlines - [ "SELECT Person.name, Person.age" - , "FROM Person" - , "WHERE Person.name = ?" - ] - queryVals - `shouldBe` - [toPersistValue ("Johhny Depp" :: TL.Text)] + asserting $ do + Text.filter (\c -> c `notElem` ['`', '"']) queryText + `shouldBe` + Text.unlines + [ "SELECT Person.name, Person.age" + , "FROM Person" + , "WHERE Person.name = ?" + ] + queryVals + `shouldBe` + [toPersistValue ("Johhny Depp" :: TL.Text)] describe "renderExpr" $ do - it "renders a value" $ do - (c, expr) <- run $ do + itDb "renders a value" $ do + (c, expr) <- do conn <- ask let Right c = P.mkEscapeChar conn let user = EI.unsafeSqlEntity (EI.I "user") blogPost = EI.unsafeSqlEntity (EI.I "blog_post") pure $ (,) c $ EI.renderExpr conn $ user ^. PersonId ==. blogPost ^. BlogPostAuthorId - expr - `shouldBe` - Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] - <> - " = " - <> - Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""] - it "renders ? for a val" $ do - expr <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) - expr `shouldBe` "? = ?" + asserting $ do + expr + `shouldBe` + Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] + <> + " = " + <> + Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""] - describe "ExprParser" $ do + itDb "renders ? for a val" $ do + expr <- ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) + asserting $ expr `shouldBe` "? = ?" + + beforeWith (\_ -> pure ()) $ describe "ExprParser" $ do let parse parser = AP.parseOnly (parser '#') describe "parseEscapedChars" $ do let subject = parse P.parseEscapedChars @@ -1786,402 +1783,399 @@ testRenderSql run = do } ] -testOnClauseOrder :: Run -> Spec -testOnClauseOrder run = describe "On Clause Ordering" $ do - let - setup :: MonadIO m => SqlPersistT m () - setup = do - ja1 <- insert (JoinOne "j1 hello") - ja2 <- insert (JoinOne "j1 world") - jb1 <- insert (JoinTwo ja1 "j2 hello") - jb2 <- insert (JoinTwo ja1 "j2 world") - jb3 <- insert (JoinTwo ja2 "j2 foo") - _ <- insert (JoinTwo ja2 "j2 bar") - jc1 <- insert (JoinThree jb1 "j3 hello") - jc2 <- insert (JoinThree jb1 "j3 world") - _ <- insert (JoinThree jb2 "j3 foo") - _ <- insert (JoinThree jb3 "j3 bar") - _ <- insert (JoinThree jb3 "j3 baz") - _ <- insert (JoinFour "j4 foo" jc1) - _ <- insert (JoinFour "j4 bar" jc2) - jd1 <- insert (JoinOther "foo") - jd2 <- insert (JoinOther "bar") - _ <- insert (JoinMany "jm foo hello" jd1 ja1) - _ <- insert (JoinMany "jm foo world" jd1 ja2) - _ <- insert (JoinMany "jm bar hello" jd2 ja1) - _ <- insert (JoinMany "jm bar world" jd2 ja2) - pure () - describe "identical results for" $ do - it "three tables" $ do - abcs <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - pure (a, b, c) - acbs <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c) -> do - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - pure (a, b, c) +testOnClauseOrder :: SpecDb +testOnClauseOrder = describe "On Clause Ordering" $ do + let + setup :: MonadIO m => SqlPersistT m () + setup = do + ja1 <- insert (JoinOne "j1 hello") + ja2 <- insert (JoinOne "j1 world") + jb1 <- insert (JoinTwo ja1 "j2 hello") + jb2 <- insert (JoinTwo ja1 "j2 world") + jb3 <- insert (JoinTwo ja2 "j2 foo") + _ <- insert (JoinTwo ja2 "j2 bar") + jc1 <- insert (JoinThree jb1 "j3 hello") + jc2 <- insert (JoinThree jb1 "j3 world") + _ <- insert (JoinThree jb2 "j3 foo") + _ <- insert (JoinThree jb3 "j3 bar") + _ <- insert (JoinThree jb3 "j3 baz") + _ <- insert (JoinFour "j4 foo" jc1) + _ <- insert (JoinFour "j4 bar" jc2) + jd1 <- insert (JoinOther "foo") + jd2 <- insert (JoinOther "bar") + _ <- insert (JoinMany "jm foo hello" jd1 ja1) + _ <- insert (JoinMany "jm foo world" jd1 ja2) + _ <- insert (JoinMany "jm bar hello" jd2 ja1) + _ <- insert (JoinMany "jm bar world" jd2 ja2) + pure () + describe "identical results for" $ do + itDb "three tables" $ do + setup + abcs <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + pure (a, b, c) + acbs <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c) -> do + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + pure (a, b, c) - listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) -> - (joinOneName j1, joinTwoName j2, joinThreeName j3) + asserting $ do + listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) -> + (joinOneName j1, joinTwoName j2, joinThreeName j3) - it "four tables" $ do - xs0 <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) - xs1 <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - pure (a, b, c, d) - xs2 <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - pure (a, b, c, d) - xs3 <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - pure (a, b, c, d) - xs4 <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - pure (a, b, c, d) + itDb "four tables" $ do + setup + xs0 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) + xs1 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + pure (a, b, c, d) + xs2 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + pure (a, b, c, d) + xs3 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + pure (a, b, c, d) + xs4 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + pure (a, b, c, d) - let getNames (j1, j2, j3, j4) = - ( joinOneName (entityVal j1) - , joinTwoName (entityVal j2) - , joinThreeName (entityVal j3) - , joinFourName (entityVal j4) - ) - listsEqualOn xs0 xs1 getNames - listsEqualOn xs0 xs2 getNames - listsEqualOn xs0 xs3 getNames - listsEqualOn xs0 xs4 getNames + let + getNames (j1, j2, j3, j4) = + ( joinOneName (entityVal j1) + , joinTwoName (entityVal j2) + , joinThreeName (entityVal j3) + , joinFourName (entityVal j4) + ) + asserting $ do + listsEqualOn xs0 xs1 getNames + listsEqualOn xs0 xs2 getNames + listsEqualOn xs0 xs3 getNames + listsEqualOn xs0 xs4 getNames - it "associativity of innerjoin" $ do - xs0 <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) + itDb "associativity of innerjoin" $ do + setup + xs0 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) - xs1 <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) + xs1 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) - xs2 <- run $ do - setup - select $ - from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) + xs2 <- + select $ + from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) - xs3 <- run $ do - setup - select $ - from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) + xs3 <- + select $ + from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) - let getNames (j1, j2, j3, j4) = - ( joinOneName (entityVal j1) - , joinTwoName (entityVal j2) - , joinThreeName (entityVal j3) - , joinFourName (entityVal j4) - ) - listsEqualOn xs0 xs1 getNames - listsEqualOn xs0 xs2 getNames - listsEqualOn xs0 xs3 getNames + let getNames (j1, j2, j3, j4) = + ( joinOneName (entityVal j1) + , joinTwoName (entityVal j2) + , joinThreeName (entityVal j3) + , joinFourName (entityVal j4) + ) + asserting $ do + listsEqualOn xs0 xs1 getNames + listsEqualOn xs0 xs2 getNames + listsEqualOn xs0 xs3 getNames - it "inner join on two entities" $ do - (xs0, xs1) <- run $ do - pid <- insert $ Person "hello" Nothing Nothing 3 - _ <- insert $ BlogPost "good poast" pid - _ <- insert $ Profile "cool" pid - xs0 <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr) -> do - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. pr ^. ProfilePerson - pure (p, b, pr) - xs1 <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr) -> do - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - pure (p, b, pr) - pure (xs0, xs1) - listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) -> - (personName p, blogPostTitle b, profileName pr) - it "inner join on three entities" $ do - res <- run $ do - pid <- insert $ Person "hello" Nothing Nothing 3 - _ <- insert $ BlogPost "good poast" pid - _ <- insert $ BlogPost "good poast #2" pid - _ <- insert $ Profile "cool" pid - _ <- insert $ Reply pid "u wot m8" - _ <- insert $ Reply pid "how dare you" + itDb "inner join on two entities" $ do + (xs0, xs1) <- do + pid <- insert $ Person "hello" Nothing Nothing 3 + _ <- insert $ BlogPost "good poast" pid + _ <- insert $ Profile "cool" pid + xs0 <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr) -> do + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. pr ^. ProfilePerson + pure (p, b, pr) + xs1 <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr) -> do + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + pure (p, b, pr) + pure (xs0, xs1) + asserting $ listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) -> + (personName p, blogPostTitle b, profileName pr) + itDb "inner join on three entities" $ do + res <- do + pid <- insert $ Person "hello" Nothing Nothing 3 + _ <- insert $ BlogPost "good poast" pid + _ <- insert $ BlogPost "good poast #2" pid + _ <- insert $ Profile "cool" pid + _ <- insert $ Reply pid "u wot m8" + _ <- insert $ Reply pid "how dare you" - bprr <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. r ^. ReplyGuy - pure (p, b, pr, r) + bprr <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. r ^. ReplyGuy + pure (p, b, pr, r) - brpr <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. r ^. ReplyGuy - on $ p ^. PersonId ==. pr ^. ProfilePerson - pure (p, b, pr, r) + brpr <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. r ^. ReplyGuy + on $ p ^. PersonId ==. pr ^. ProfilePerson + pure (p, b, pr, r) - prbr <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. r ^. ReplyGuy - pure (p, b, pr, r) + prbr <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. r ^. ReplyGuy + pure (p, b, pr, r) - prrb <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. r ^. ReplyGuy - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - pure (p, b, pr, r) + prrb <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. r ^. ReplyGuy + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + pure (p, b, pr, r) - rprb <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. r ^. ReplyGuy - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - pure (p, b, pr, r) + rprb <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. r ^. ReplyGuy + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + pure (p, b, pr, r) - rbpr <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. r ^. ReplyGuy - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. pr ^. ProfilePerson - pure (p, b, pr, r) + rbpr <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. r ^. ReplyGuy + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. pr ^. ProfilePerson + pure (p, b, pr, r) - pure [bprr, brpr, prbr, prrb, rprb, rbpr] - forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b + pure [bprr, brpr, prbr, prrb, rprb, rbpr] + asserting $ forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b - it "many-to-many" $ do - ac <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c) -> do - on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) - on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) - pure (a, c) + itDb "many-to-many" $ do + setup + ac <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c) -> do + on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) + on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) + pure (a, c) - ca <- run $ do - setup - select $ - from $ \(a `InnerJoin` b `InnerJoin` c) -> do - on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) - on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) - pure (a, c) + ca <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c) -> do + on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) + on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) + pure (a, c) - listsEqualOn ac ca $ \(Entity _ a, Entity _ b) -> - (joinOneName a, joinOtherName b) + asserting $ listsEqualOn ac ca $ \(Entity _ a, Entity _ b) -> + (joinOneName a, joinOtherName b) - it "left joins on order" $ do - ca <- run $ do - setup - select $ - from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do - on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) - on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) - orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] - pure (a, c) - ac <- run $ do - setup - select $ - from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do - on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) - on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) - orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] - pure (a, c) + itDb "left joins on order" $ do + setup + ca <- + select $ + from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do + on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) + on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) + orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] + pure (a, c) + ac <- + select $ + from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do + on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) + on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) + orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] + pure (a, c) - listsEqualOn ac ca $ \(Entity _ a, b) -> - (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) + asserting $ listsEqualOn ac ca $ \(Entity _ a, b) -> + (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) - it "doesn't require an on for a crossjoin" $ do - void $ run $ - select $ - from $ \(a `CrossJoin` b) -> do - pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo)) + itDb "doesn't require an on for a crossjoin" $ do + void $ + select $ + from $ \(a `CrossJoin` b) -> do + pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo)) + asserting noExceptions - it "errors with an on for a crossjoin" $ do - (void $ run $ - select $ - from $ \(a `CrossJoin` b) -> do - on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne - pure (a, b)) - `shouldThrow` \(OnClauseWithoutMatchingJoinException _) -> - True + itDb "errors with an on for a crossjoin" $ do + eres <- + try $ + select $ + from $ \(a `CrossJoin` b) -> do + on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne + pure (a, b) + asserting $ + case eres of + Left (OnClauseWithoutMatchingJoinException _) -> + pure () + Right _ -> + expectationFailure "Expected OnClause exception" - it "left joins associativity" $ do - ca <- run $ do - setup - select $ - from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do - on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) - on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) - orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] - pure (a, c) - ca' <- run $ do - setup - select $ - from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do - on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) - on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) - orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] - pure (a, c) + itDb "left joins associativity" $ do + setup + ca <- + select $ + from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do + on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) + on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) + orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] + pure (a, c) + ca' <- + select $ + from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do + on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) + on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) + orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] + pure (a, c) - listsEqualOn ca ca' $ \(Entity _ a, b) -> - (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) + asserting $ listsEqualOn ca ca' $ \(Entity _ a, b) -> + (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) - it "composes queries still" $ do - let - query1 = - from $ \(foo `InnerJoin` bar) -> do - on (foo ^. FooId ==. bar ^. BarQuux) - pure (foo, bar) - query2 = - from $ \(p `LeftOuterJoin` bp) -> do - on (p ^. PersonId ==. bp ^. BlogPostAuthorId) - pure (p, bp) - (a, b) <- run $ do - fid <- insert $ Foo 5 - _ <- insert $ Bar fid - pid <- insert $ Person "hey" Nothing Nothing 30 - _ <- insert $ BlogPost "WHY" pid - a <- select ((,) <$> query1 <*> query2) - b <- select (flip (,) <$> query1 <*> query2) - pure (a, b) - listsEqualOn a (map (\(x, y) -> (y, x)) b) id + itDb "composes queries still" $ do + let + query1 = + from $ \(foo `InnerJoin` bar) -> do + on (foo ^. FooId ==. bar ^. BarQuux) + pure (foo, bar) + query2 = + from $ \(p `LeftOuterJoin` bp) -> do + on (p ^. PersonId ==. bp ^. BlogPostAuthorId) + pure (p, bp) + fid <- insert $ Foo 5 + _ <- insert $ Bar fid + pid <- insert $ Person "hey" Nothing Nothing 30 + _ <- insert $ BlogPost "WHY" pid + a <- select ((,) <$> query1 <*> query2) + b <- select (flip (,) <$> query1 <*> query2) + asserting $ listsEqualOn a (map (\(x, y) -> (y, x)) b) id - it "works with joins in subselect" $ do - run $ void $ - select $ - from $ \(p `InnerJoin` r) -> do - on $ p ^. PersonId ==. r ^. ReplyGuy - pure . (,) (p ^. PersonName) $ - subSelect $ - from $ \(c `InnerJoin` bp) -> do - on $ bp ^. BlogPostId ==. c ^. CommentBlog - pure (c ^. CommentBody) + itDb "works with joins in subselect" $ do + select $ + from $ \(p `InnerJoin` r) -> do + on $ p ^. PersonId ==. r ^. ReplyGuy + pure . (,) (p ^. PersonName) $ + subSelect $ + from $ \(c `InnerJoin` bp) -> do + on $ bp ^. BlogPostId ==. c ^. CommentBlog + pure (c ^. CommentBody) + asserting noExceptions - describe "works with nested joins" $ do - it "unnested" $ do - run $ void $ - selectRethrowingQuery $ - from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - pure ( f ^. FooName) - it "leftmost nesting" $ do - run $ void $ - selectRethrowingQuery $ - from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - pure ( f ^. FooName) - describe "middle nesting" $ do - it "direct association" $ do - run $ void $ - selectRethrowingQuery $ - from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do - on $ p ^. PersonId ==. bp ^. BlogPostAuthorId - on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog - on $ c ?. CommentId ==. cr ?. CommentReplyComment - pure (p,bp,c,cr) - it "indirect association" $ do - run $ void $ - selectRethrowingQuery $ - from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId - pure (f ^. FooName) - it "indirect association across" $ do - run $ void $ - selectRethrowingQuery $ - from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId - on $ another ^. AnotherWhy ==. baz ^. BazId - on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId - pure (f ^. FooName) + describe "works with nested joins" $ do + itDb "unnested" $ do + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure ( f ^. FooName) + asserting noExceptions - describe "rightmost nesting" $ do - it "direct associations" $ do - run $ void $ - selectRethrowingQuery $ - from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do - on $ p ^. PersonId ==. bp ^. BlogPostAuthorId - on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog - on $ c ?. CommentId ==. cr ?. CommentReplyComment - pure (p,bp,c,cr) + itDb "leftmost nesting" $ do + selectRethrowingQuery $ + from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure ( f ^. FooName) + asserting noExceptions + describe "middle nesting" $ do + itDb "direct association" $ do + selectRethrowingQuery $ + from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do + on $ p ^. PersonId ==. bp ^. BlogPostAuthorId + on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog + on $ c ?. CommentId ==. cr ?. CommentReplyComment + pure (p,bp,c,cr) + asserting noExceptions + itDb "indirect association" $ do + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId + pure (f ^. FooName) + asserting noExceptions + itDb "indirect association across" $ do + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId + on $ another ^. AnotherWhy ==. baz ^. BazId + on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId + pure (f ^. FooName) + asserting noExceptions - it "indirect association" $ do - run $ void $ - selectRethrowingQuery $ - from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - pure (f ^. FooName) + describe "rightmost nesting" $ do + itDb "direct associations" $ do + selectRethrowingQuery $ + from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do + on $ p ^. PersonId ==. bp ^. BlogPostAuthorId + on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog + on $ c ?. CommentId ==. cr ?. CommentReplyComment + pure (p,bp,c,cr) + asserting noExceptions -testExperimentalFrom :: Run -> Spec -testExperimentalFrom run = do + itDb "indirect association" $ do + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure (f ^. FooName) + asserting noExceptions + +testExperimentalFrom :: SpecDb +testExperimentalFrom = do describe "Experimental From" $ do - it "supports basic table queries" $ do - run $ do + itDb "supports basic table queries" $ do p1e <- insert' p1 _ <- insert' p2 p3e <- insert' p3 @@ -2189,10 +2183,9 @@ testExperimentalFrom run = do people <- Experimental.from $ Table @Person where_ $ not_ $ isNothing $ people ^. PersonAge return people - liftIO $ peopleWithAges `shouldMatchList` [p1e, p3e] + asserting $ peopleWithAges `shouldMatchList` [p1e, p3e] - it "supports inner joins" $ do - run $ do + itDb "supports inner joins" $ do l1e <- insert' l1 _ <- insert l2 d1e <- insert' $ Deed "1" (entityKey l1e) @@ -2203,12 +2196,11 @@ testExperimentalFrom run = do `InnerJoin` Table @Deed `Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId) pure (lords, deeds) - liftIO $ lordDeeds `shouldMatchList` [ (l1e, d1e) + asserting $ lordDeeds `shouldMatchList` [ (l1e, d1e) , (l1e, d2e) ] - it "supports outer joins" $ do - run $ do + itDb "supports outer joins" $ do l1e <- insert' l1 l2e <- insert' l2 d1e <- insert' $ Deed "1" (entityKey l1e) @@ -2220,21 +2212,19 @@ testExperimentalFrom run = do `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) pure (lords, deeds) - liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e) + asserting $ lordDeeds `shouldMatchList` [ (l1e, Just d1e) , (l1e, Just d2e) , (l2e, Nothing) ] - it "supports delete" $ do - run $ do + itDb "supports delete" $ do insert_ l1 insert_ l2 insert_ l3 delete $ void $ Experimental.from $ Table @Lord lords <- select $ Experimental.from $ Table @Lord - liftIO $ lords `shouldMatchList` [] + asserting $ lords `shouldMatchList` [] - it "supports implicit cross joins" $ do - run $ do + itDb "supports implicit cross joins" $ do l1e <- insert' l1 l2e <- insert' l2 ret <- select $ do @@ -2244,16 +2234,15 @@ testExperimentalFrom run = do ret2 <- select $ do (lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord pure (lords1,lords2) - liftIO $ ret `shouldMatchList` ret2 - liftIO $ ret `shouldMatchList` [ (l1e, l1e) + asserting $ ret `shouldMatchList` ret2 + asserting $ ret `shouldMatchList` [ (l1e, l1e) , (l1e, l2e) , (l2e, l1e) , (l2e, l2e) ] - it "compiles" $ do - run $ void $ do + itDb "compiles" $ do let q = do (persons :& profiles :& posts) <- Experimental.from $ Table @Person @@ -2264,11 +2253,9 @@ testExperimentalFrom run = do `Experimental.on` (\(people :& _ :& posts) -> just (people ^. PersonId) ==. posts ?. BlogPostAuthorId) pure (persons, posts, profiles) - --error . show =<< renderQuerySelect q - pure () + asserting noExceptions - it "can call functions on aliased values" $ do - run $ do + itDb "can call functions on aliased values" $ do insert_ p1 insert_ p3 -- Pretend this isnt all posts @@ -2276,38 +2263,38 @@ testExperimentalFrom run = do author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person pure $ upper_ $ author ^. PersonName - liftIO $ upperNames `shouldMatchList` [ Value "JOHN" + asserting $ upperNames `shouldMatchList` [ Value "JOHN" , Value "MIKE" ] -listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation +listsEqualOn :: (HasCallStack, Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation listsEqualOn a b f = map f a `shouldBe` map f b -tests :: Run -> Spec -tests run = do +tests :: SpecDb +tests = do describe "Esqueleto" $ do - testSelect run - testSubSelect run - testSelectSource run - testSelectFrom run - testSelectJoin run - testSelectSubQuery run - testSelectWhere run - testSelectOrderBy run - testSelectDistinct run - testCoasleceDefault run - testDelete run - testUpdate run - testListOfValues run - testListFields run - testInsertsBySelect run - testMathFunctions run - testCase run - testCountingRows run - testRenderSql run - testOnClauseOrder run - testExperimentalFrom run - + testSelect + testSubSelect + testSelectSource + testSelectFrom + testSelectJoin + testSelectSubQuery + testSelectWhere + testSelectOrderBy + testSelectDistinct + testCoasleceDefault + testDelete + testUpdate + testListOfValues + testListFields + testInsertsBySelect + testMathFunctions + testCase + testCountingRows + testRenderSql + testOnClauseOrder + testExperimentalFrom + testLocking insert' :: ( Functor m , BaseBackend backend ~ PersistEntityBackend val @@ -2323,8 +2310,8 @@ insert' v = flip Entity v <$> insert v -- thus must be cleaned after each test. -- TODO: there is certainly a better way... cleanDB - :: (forall m. RunDbMonad m - => SqlPersistT (R.ResourceT m) ()) + :: forall m. _ + => SqlPersistT m () cleanDB = do delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return () @@ -2363,10 +2350,10 @@ cleanDB = do cleanUniques - :: (forall m. RunDbMonad m - => SqlPersistT (R.ResourceT m) ()) + :: forall m. MonadIO m + => SqlPersistT m () cleanUniques = - delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return () selectRethrowingQuery :: (MonadIO m, EI.SqlSelect a r, MonadUnliftIO m) @@ -2391,3 +2378,15 @@ updateRethrowingQuery k = `catch` \(SomeException e) -> do (text, _) <- renderQueryUpdate (from k) liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e + +shouldBeOnClauseWithoutMatchingJoinException + :: (HasCallStack, Show a) + => Either SomeException a + -> Expectation +shouldBeOnClauseWithoutMatchingJoinException ea = + case ea of + Left (fromException -> Just OnClauseWithoutMatchingJoinException {}) -> + pure () + _ -> + expectationFailure $ "Expected OnClauseWithMatchingJoinException, got: " <> show ea + diff --git a/test/Common/Test/Import.hs b/test/Common/Test/Import.hs index 61af32f..51d9372 100644 --- a/test/Common/Test/Import.hs +++ b/test/Common/Test/Import.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -25,23 +25,63 @@ module Common.Test.Import , module X ) where -import Control.Monad.Fail +import System.Environment +import Control.Applicative import Common.Test.Models as X -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Logger (MonadLogger(..), MonadLoggerIO(..)) -import Database.Esqueleto.Experimental as X +import Database.Esqueleto.Experimental as X hiding (random_) import Test.Hspec as X import UnliftIO as X -import qualified UnliftIO.Resource as R +import Control.Monad +import Test.QuickCheck +import Data.Text as X (Text) +import Control.Monad.Trans.Reader as X (ReaderT, mapReaderT, ask) -type RunDbMonad m = - ( MonadUnliftIO m - , MonadIO m - , MonadLoggerIO m - , MonadLogger m - , MonadCatch m - ) +type SpecDb = SpecWith ConnectionPool -type Run = forall a. (forall m. (RunDbMonad m, MonadFail m) => SqlPersistT (R.ResourceT m) a) -> IO a +asserting :: MonadIO f => IO () -> SqlPersistT f () +asserting a = liftIO a -type WithConn m a = RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a +noExceptions :: Expectation +noExceptions = pure () + +itDb + :: (HasCallStack) + => String + -> SqlPersistT IO x + -> SpecDb +itDb message action = do + it message $ \connection -> do + void $ testDb connection action + +propDb + :: (HasCallStack, Testable a) + => String + -> ((SqlPersistT IO () -> IO ()) -> a ) + -> SpecDb +propDb message action = do + it message $ \connection -> do + property (action (testDb connection)) + +testDb :: ConnectionPool -> SqlPersistT IO a -> IO a +testDb conn action = + liftIO $ flip runSqlPool conn $ do + a <- action + transactionUndo + pure a + +setDatabaseState + :: SqlPersistT IO a + -> SqlPersistT IO () + -> SpecWith ConnectionPool + -> SpecWith ConnectionPool +setDatabaseState create clean test = + beforeWith (\conn -> runSqlPool create conn >> pure conn) $ + after (\conn -> runSqlPool clean conn) $ + test + +isCI :: IO Bool +isCI = do + env <- getEnvironment + return $ case lookup "TRAVIS" env <|> lookup "CI" env of + Just "true" -> True + _ -> False diff --git a/test/Common/Test/Select.hs b/test/Common/Test/Select.hs index 14fbd87..e1c36f6 100644 --- a/test/Common/Test/Select.hs +++ b/test/Common/Test/Select.hs @@ -2,25 +2,21 @@ module Common.Test.Select where import Common.Test.Import -testSelect :: Run -> Spec -testSelect run = do +testSelect :: SpecDb +testSelect = do describe "select" $ do - it "works for a single value" $ - run $ do - ret <- select $ return $ val (3 :: Int) - liftIO $ ret `shouldBe` [ Value 3 ] + itDb "works for a single value" $ do + ret <- select $ return $ val (3 :: Int) + asserting $ ret `shouldBe` [ Value 3 ] - it "works for a pair of a single value and ()" $ - run $ do - ret <- select $ return (val (3 :: Int), ()) - liftIO $ ret `shouldBe` [ (Value 3, ()) ] + itDb "works for a pair of a single value and ()" $ do + ret <- select $ return (val (3 :: Int), ()) + asserting $ ret `shouldBe` [ (Value 3, ()) ] - it "works for a single ()" $ - run $ do - ret <- select $ return () - liftIO $ ret `shouldBe` [ () ] + itDb "works for a single ()" $ do + ret <- select $ return () + asserting $ ret `shouldBe` [ () ] - it "works for a single NULL value" $ - run $ do - ret <- select $ return nothing - liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ] + itDb "works for a single NULL value" $ do + ret <- select $ return nothing + asserting $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ] diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index 5fb72a4..6941328 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -6,11 +6,13 @@ module MySQL.Test where +import Common.Test.Import hiding (from, on) + import Control.Applicative import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) -import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Reader (ReaderT, mapReaderT) import qualified Control.Monad.Trans.Resource as R import Database.Esqueleto import Database.Esqueleto.Experimental hiding (from, on) @@ -23,30 +25,16 @@ import Database.Persist.MySQL , connectUser , defaultConnectInfo , withMySQLConn + , createMySQLPool ) -import System.Environment import Test.Hspec import Common.Test - --- testMysqlRandom :: Spec --- testMysqlRandom = do --- -- This is known not to work until --- -- we can differentiate behavior by database --- it "works with random_" $ --- run $ do --- _ <- select $ return (random_ :: SqlExpr (Value Double)) --- return () - - - - -testMysqlSum :: Spec +testMysqlSum :: SpecDb testMysqlSum = do - it "works with sum_" $ - run $ do + itDb "works with sum_" $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3 @@ -56,13 +44,9 @@ testMysqlSum = do return $ joinV $ sum_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ] - - - -testMysqlTwoAscFields :: Spec +testMysqlTwoAscFields :: SpecDb testMysqlTwoAscFields = do - it "works with two ASC fields (one call)" $ - run $ do + itDb "works with two ASC fields (one call)" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 @@ -73,13 +57,9 @@ testMysqlTwoAscFields = do return p liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] - - - -testMysqlOneAscOneDesc :: Spec +testMysqlOneAscOneDesc :: SpecDb testMysqlOneAscOneDesc = do - it "works with one ASC and one DESC field (two calls)" $ - run $ do + itDb "works with one ASC and one DESC field (two calls)" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 @@ -94,10 +74,9 @@ testMysqlOneAscOneDesc = do -testMysqlCoalesce :: Spec +testMysqlCoalesce :: SpecDb testMysqlCoalesce = do - it "works on PostgreSQL and MySQL with <2 arguments" $ - run $ do + itDb "works on PostgreSQL and MySQL with <2 arguments" $ do _ :: [Value (Maybe Int)] <- select $ from $ \p -> do @@ -107,10 +86,9 @@ testMysqlCoalesce = do -testMysqlUpdate :: Spec +testMysqlUpdate :: SpecDb testMysqlUpdate = do - it "works on a simple example" $ - run $ do + itDb "works on a simple example" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 @@ -133,20 +111,13 @@ testMysqlUpdate = do , Entity p1k (Person anon (Just 73) Nothing 1) , Entity p3k p3 ] - - - -nameContains :: (BaseBackend backend ~ SqlBackend, - BackendCompatible SqlBackend backend, - MonadIO m, SqlString s, - IsPersistBackend backend, PersistQueryRead backend, - PersistUniqueRead backend) +nameContains :: (SqlString s) => (SqlExpr (Value [Char]) -> SqlExpr (Value s) -> SqlExpr (Value Bool)) -> s -> [Entity Person] - -> ReaderT backend m () + -> SqlPersistT IO () nameContains f t expected = do ret <- select $ from $ \p -> do @@ -158,22 +129,20 @@ nameContains f t expected = do liftIO $ ret `shouldBe` expected -testMysqlTextFunctions :: Spec +testMysqlTextFunctions :: SpecDb testMysqlTextFunctions = do describe "text functions" $ do - it "like, (%) and (++.) work on a simple example" $ - run $ do + itDb "like, (%) and (++.) work on a simple example" $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] nameContains like "h" [p1e, p2e] nameContains like "i" [p4e, p3e] nameContains like "iv" [p4e] -testMysqlUnionWithLimits :: Spec +testMysqlUnionWithLimits :: SpecDb testMysqlUnionWithLimits = do describe "MySQL Union" $ do - it "supports limit/orderBy by parenthesizing" $ do - run $ do + itDb "supports limit/orderBy by parenthesizing" $ do mapM_ (insert . Foo) [1..6] let q1 = do @@ -195,11 +164,8 @@ testMysqlUnionWithLimits = do liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5] spec :: Spec -spec = do - tests run - - describe "Test MySQL locking" $ do - testLocking withConn +spec = beforeAll mkConnectionPool $ do + tests describe "MySQL specific tests" $ do -- definitely doesn't work at the moment @@ -212,32 +178,17 @@ spec = do testMysqlTextFunctions testMysqlUnionWithLimits -run, runSilent, runVerbose :: Run -runSilent act = runNoLoggingT $ run_worker act -runVerbose act = runStderrLoggingT $ run_worker act -run = - if verbose - then runVerbose - else runSilent - - verbose :: Bool verbose = False - -run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a -run_worker act = withConn $ runSqlConn (migrateIt >> act) - - -migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) () +migrateIt :: R.MonadUnliftIO m => SqlPersistT m () migrateIt = do - void $ runMigrationSilent migrateAll + mapReaderT R.runResourceT $ void $ runMigrationSilent migrateAll cleanDB - -withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a -withConn f = do - ci <- liftIO isCI +mkConnectionPool :: IO ConnectionPool +mkConnectionPool = do + ci <- isCI let connInfo | ci = defaultConnectInfo @@ -255,12 +206,18 @@ withConn f = do , connectDatabase = "esqutest" , connectPort = 3306 } - R.runResourceT $ withMySQLConn connInfo f + pool <- + if verbose + then + runStderrLoggingT $ + createMySQLPool connInfo 4 + else + runNoLoggingT $ + createMySQLPool connInfo 4 -isCI :: IO Bool -isCI = do - env <- getEnvironment - return $ case lookup "TRAVIS" env <|> lookup "CI" env of - Just "true" -> True - _ -> False + flip runSqlPool pool $ do + migrateIt + cleanDB + + pure pool diff --git a/test/PostgreSQL/MigrateJSON.hs b/test/PostgreSQL/MigrateJSON.hs index b450524..91809e5 100644 --- a/test/PostgreSQL/MigrateJSON.hs +++ b/test/PostgreSQL/MigrateJSON.hs @@ -16,15 +16,12 @@ module PostgreSQL.MigrateJSON where -import Control.Monad.Trans.Resource (ResourceT) -import Data.Aeson (Value) -import Database.Esqueleto (SqlExpr, delete, from) -import Database.Esqueleto.PostgreSQL.JSON (JSONB) -import Database.Persist (Entity) -import Database.Persist.Sql (SqlPersistT) -import Database.Persist.TH +import Common.Test.Import hiding (Value, from, on) -import Common.Test (RunDbMonad) +import Data.Aeson (Value) +import Database.Esqueleto.Legacy (from) +import Database.Esqueleto.PostgreSQL.JSON (JSONB) +import Database.Persist.TH -- JSON Table for PostgreSQL share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase| @@ -34,6 +31,6 @@ Json |] cleanJSON - :: (forall m. RunDbMonad m - => SqlPersistT (ResourceT m) ()) + :: forall m. MonadIO m + => SqlPersistT m () cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return () diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 9783986..d5e9848 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -13,10 +13,9 @@ module PostgreSQL.Test where import Control.Arrow ((&&&)) import Control.Monad (void, when) -import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) -import Control.Monad.Trans.Reader (ReaderT, ask) +import Control.Monad.Trans.Reader (ReaderT, ask, mapReaderT) import qualified Control.Monad.Trans.Resource as R import Data.Aeson hiding (Value) import qualified Data.Aeson as A (Value) @@ -41,157 +40,128 @@ import Database.Esqueleto.PostgreSQL (random_) import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON -import Database.Persist.Postgresql (withPostgresqlConn) +import Database.Persist.Postgresql (withPostgresqlConn, createPostgresqlPool) import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..)) import System.Environment import Test.Hspec import Test.Hspec.QuickCheck import Common.Test +import Common.Test.Import hiding (from, on) import PostgreSQL.MigrateJSON +returningType :: forall a m . m a -> m a +returningType a = a - -testPostgresqlCoalesce :: Spec +testPostgresqlCoalesce :: SpecDb testPostgresqlCoalesce = do - it "works on PostgreSQL and MySQL with <2 arguments" $ - run $ do - _ :: [Value (Maybe Int)] <- - select $ - from $ \p -> do - return (coalesce [p ^. PersonAge]) - return () + itDb "works on PostgreSQL and MySQL with <2 arguments" $ do + void $ returningType @[Value (Maybe Int)] $ + select $ + from $ \p -> do + return (coalesce [p ^. PersonAge]) + asserting noExceptions -nameContains :: (BaseBackend backend ~ SqlBackend, - BackendCompatible SqlBackend backend, - MonadIO m, SqlString s, - IsPersistBackend backend, PersistQueryRead backend, - PersistUniqueRead backend) - => (SqlExpr (Value [Char]) - -> SqlExpr (Value s) - -> SqlExpr (Value Bool)) - -> s - -> [Entity Person] - -> ReaderT backend m () -nameContains f t expected = do - ret <- select $ - from $ \p -> do - where_ (f - (p ^. PersonName) - ((%) ++. val t ++. (%))) - orderBy [asc (p ^. PersonName)] - return p - liftIO $ ret `shouldBe` expected - - -testPostgresqlTextFunctions :: Spec +testPostgresqlTextFunctions :: SpecDb testPostgresqlTextFunctions = do - describe "text functions" $ do - it "like, (%) and (++.) work on a simple example" $ - run $ do - [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] - nameContains like "h" [p1e, p2e] - nameContains like "i" [p4e, p3e] - nameContains like "iv" [p4e] + describe "text functions" $ do + itDb "like, (%) and (++.) work on a simple example" $ do + let nameContains t = + select $ + from $ \p -> do + where_ + (like + (p ^. PersonName) + ((%) ++. val t ++. (%))) + orderBy [asc (p ^. PersonName)] + return p + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + h <- nameContains "h" + i <- nameContains "i" + iv <- nameContains "iv" + asserting $ do + h `shouldBe` [p1e, p2e] + i `shouldBe` [p4e, p3e] + iv `shouldBe` [p4e] - it "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ - run $ do - [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] - let nameContains' t expected = do - ret <- select $ + itDb "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ do + [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] + let nameContains t = do + select $ from $ \p -> do where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%)) orderBy [asc (p ^. PersonName)] return p - liftIO $ ret `shouldBe` expected - nameContains' "mi" [p3e, p5e] - nameContains' "JOHN" [p1e] + mi <- nameContains "mi" + john <- nameContains "JOHN" + asserting $ do + mi `shouldBe` [p3e, p5e] + john `shouldBe` [p1e] - - - - -testPostgresqlUpdate :: Spec +testPostgresqlUpdate :: SpecDb testPostgresqlUpdate = do - it "works on a simple example" $ - run $ do - p1k <- insert p1 - p2k <- insert p2 - p3k <- insert p3 - let anon = "Anonymous" - () <- update $ \p -> do - set p [ PersonName =. val anon - , PersonAge *=. just (val 2) ] - where_ (p ^. PersonName !=. val "Mike") - n <- updateCount $ \p -> do - set p [ PersonAge +=. just (val 1) ] - where_ (p ^. PersonName !=. val "Mike") - ret <- select $ - from $ \p -> do - orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] - return p - -- PostgreSQL: nulls are bigger than data, and update returns - -- matched rows, not actually changed rows. - liftIO $ n `shouldBe` 2 - liftIO $ ret `shouldBe` [ Entity p1k (Person anon (Just 73) Nothing 1) - , Entity p2k (Person anon Nothing (Just 37) 2) - , Entity p3k p3 ] + itDb "works on a simple example" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + let anon = "Anonymous" + () <- update $ \p -> do + set p [ PersonName =. val anon + , PersonAge *=. just (val 2) ] + where_ (p ^. PersonName !=. val "Mike") + n <- updateCount $ \p -> do + set p [ PersonAge +=. just (val 1) ] + where_ (p ^. PersonName !=. val "Mike") + ret <- select $ + from $ \p -> do + orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] + return p + -- PostgreSQL: nulls are bigger than data, and update returns + -- matched rows, not actually changed rows. + asserting $ do + n `shouldBe` 2 + ret `shouldBe` + [ Entity p1k (Person anon (Just 73) Nothing 1) + , Entity p2k (Person anon Nothing (Just 37) 2) + , Entity p3k p3 + ] - - - - -testPostgresqlRandom :: Spec +testPostgresqlRandom :: SpecDb testPostgresqlRandom = do - it "works with random_" $ - run $ do - _ <- select $ return (random_ :: SqlExpr (Value Double)) - return () + itDb "works with random_" $ do + _ <- select $ return (random_ :: SqlExpr (Value Double)) + asserting noExceptions - - - - -testPostgresqlSum :: Spec +testPostgresqlSum :: SpecDb testPostgresqlSum = do - it "works with sum_" $ - run $ do - _ <- insert' p1 - _ <- insert' p2 - _ <- insert' p3 - _ <- insert' p4 - ret <- select $ - from $ \p-> - return $ joinV $ sum_ (p ^. PersonAge) - liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ] + itDb "works with sum_" $ do + _ <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + _ <- insert' p4 + ret <- select $ + from $ \p-> + return $ joinV $ sum_ (p ^. PersonAge) + asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ] - - - - -testPostgresqlTwoAscFields :: Spec +testPostgresqlTwoAscFields :: SpecDb testPostgresqlTwoAscFields = do - it "works with two ASC fields (one call)" $ - run $ do - p1e <- insert' p1 - p2e <- insert' p2 - p3e <- insert' p3 - p4e <- insert' p4 - ret <- select $ - from $ \p -> do - orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] - return p - -- in PostgreSQL nulls are bigger than everything - liftIO $ ret `shouldBe` [ p4e, p3e, p1e , p2e ] + itDb "works with two ASC fields (one call)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] + return p + -- in PostgreSQL nulls are bigger than everything + asserting $ ret `shouldBe` [ p4e, p3e, p1e , p2e ] - - - - -testPostgresqlOneAscOneDesc :: Spec +testPostgresqlOneAscOneDesc :: SpecDb testPostgresqlOneAscOneDesc = do - it "works with one ASC and one DESC field (two calls)" $ - run $ do + itDb "works with one ASC and one DESC field (two calls)" $ + do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 @@ -201,17 +171,13 @@ testPostgresqlOneAscOneDesc = do orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)] return p - liftIO $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] + asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] - - - - -testSelectDistinctOn :: Spec +testSelectDistinctOn :: SpecDb testSelectDistinctOn = do describe "SELECT DISTINCT ON" $ do - it "works on a simple example" $ do - run $ do + itDb "works on a simple example" $ do + do [p1k, p2k, _] <- mapM insert [p1, p2, p3] [_, bpB, bpC] <- mapM insert' [ BlogPost "A" p1k @@ -225,7 +191,7 @@ testSelectDistinctOn = do liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC] let slightlyLessSimpleTest q = - run $ do + do [p1k, p2k, _] <- mapM insert [p1, p2, p3] [bpA, bpB, bpC] <- mapM insert' [ BlogPost "A" p1k @@ -237,20 +203,20 @@ testSelectDistinctOn = do let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC] - it "works on a slightly less simple example (two distinctOn calls, orderBy)" $ + itDb "works on a slightly less simple example (two distinctOn calls, orderBy)" $ slightlyLessSimpleTest $ \bp act -> distinctOn [don (bp ^. BlogPostAuthorId)] $ distinctOn [don (bp ^. BlogPostTitle)] $ do orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] act - it "works on a slightly less simple example (one distinctOn call, orderBy)" $ do + itDb "works on a slightly less simple example (one distinctOn call, orderBy)" $ do slightlyLessSimpleTest $ \bp act -> distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] act - it "works on a slightly less simple example (distinctOnOrderBy)" $ do + itDb "works on a slightly less simple example (distinctOnOrderBy)" $ do slightlyLessSimpleTest $ \bp -> distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] @@ -258,10 +224,10 @@ testSelectDistinctOn = do -testArrayAggWith :: Spec +testArrayAggWith :: SpecDb testArrayAggWith = do describe "ALL, no ORDER BY" $ do - it "creates sane SQL" $ run $ do + itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) []) liftIO $ query `shouldBe` @@ -269,7 +235,7 @@ testArrayAggWith = do \FROM \"Person\"\n" liftIO $ args `shouldBe` [] - it "works on an example" $ run $ do + itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -278,7 +244,7 @@ testArrayAggWith = do liftIO $ L.sort ret `shouldBe` L.sort (map personName people) describe "DISTINCT, no ORDER BY" $ do - it "creates sane SQL" $ run $ do + itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) liftIO $ query `shouldBe` @@ -286,7 +252,7 @@ testArrayAggWith = do \FROM \"Person\"\n" liftIO $ args `shouldBe` [] - it "works on an example" $ run $ do + itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -295,7 +261,7 @@ testArrayAggWith = do liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36] describe "ALL, ORDER BY" $ do - it "creates sane SQL" $ run $ do + itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) [ asc $ p ^. PersonName @@ -307,7 +273,7 @@ testArrayAggWith = do \FROM \"Person\"\n" liftIO $ args `shouldBe` [] - it "works on an example" $ run $ do + itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -316,7 +282,7 @@ testArrayAggWith = do liftIO $ L.sort ret `shouldBe` L.sort (map personName people) describe "DISTINCT, ORDER BY" $ do - it "creates sane SQL" $ run $ do + itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [asc $ p ^. PersonAge]) @@ -326,7 +292,7 @@ testArrayAggWith = do \FROM \"Person\"\n" liftIO $ args `shouldBe` [] - it "works on an example" $ run $ do + itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -339,10 +305,10 @@ testArrayAggWith = do -testStringAggWith :: Spec +testStringAggWith :: SpecDb testStringAggWith = do describe "ALL, no ORDER BY" $ do - it "creates sane SQL" $ run $ do + itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") []) @@ -351,7 +317,7 @@ testStringAggWith = do \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] - it "works on an example" $ run $ do + itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -359,14 +325,14 @@ testStringAggWith = do return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people) - it "works with zero rows" $ run $ do + itDb "works with zero rows" $ do [Value ret] <- select $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) liftIO $ ret `shouldBe` Nothing describe "DISTINCT, no ORDER BY" $ do - it "creates sane SQL" $ run $ do + itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [] @@ -375,7 +341,7 @@ testStringAggWith = do \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] - it "works on an example" $ run $ do + itDb "works on an example" $ do let people = [p1, p2, p3 {personName = "John"}, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -386,7 +352,7 @@ testStringAggWith = do (L.sort . L.nub $ map personName people) describe "ALL, ORDER BY" $ do - it "creates sane SQL" $ run $ do + itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") [ asc $ p ^. PersonName @@ -398,7 +364,7 @@ testStringAggWith = do \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] - it "works on an example" $ run $ do + itDb "works on an example" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -409,7 +375,7 @@ testStringAggWith = do `shouldBe` (L.reverse . L.sort $ map personName people) describe "DISTINCT, ORDER BY" $ do - it "creates sane SQL" $ run $ do + itDb "creates sane SQL" $ do (query, args) <- showQuery ES.SELECT $ from $ \p -> return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [desc $ p ^. PersonName] @@ -419,7 +385,7 @@ testStringAggWith = do \FROM \"Person\"\n" liftIO $ args `shouldBe` [PersistText " "] - it "works on an example" $ run $ do + itDb "works on an example" $ do let people = [p1, p2, p3 {personName = "John"}, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -433,24 +399,24 @@ testStringAggWith = do -testAggregateFunctions :: Spec +testAggregateFunctions :: SpecDb testAggregateFunctions = do describe "arrayAgg" $ do - it "looks sane" $ run $ do + itDb "looks sane" $ do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName)) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) - it "works on zero rows" $ run $ do + itDb "works on zero rows" $ do [Value ret] <- select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName)) liftIO $ ret `shouldBe` Nothing describe "arrayAggWith" testArrayAggWith describe "stringAgg" $ do - it "looks sane" $ - run $ do + itDb "looks sane" $ + do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- @@ -458,14 +424,14 @@ testAggregateFunctions = do from $ \p -> do return (EP.stringAgg (p ^. PersonName) (val " ")) liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people) - it "works on zero rows" $ run $ do + itDb "works on zero rows" $ do [Value ret] <- select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " ")) liftIO $ ret `shouldBe` Nothing describe "stringAggWith" testStringAggWith describe "array_remove (NULL)" $ do - it "removes NULL from arrays from nullable fields" $ run $ do + itDb "removes NULL from arrays from nullable fields" $ do mapM_ insert [ Person "1" Nothing Nothing 1 , Person "2" (Just 7) Nothing 1 , Person "3" (Nothing) Nothing 1 @@ -480,127 +446,118 @@ testAggregateFunctions = do `shouldBe` [[7], [8,9]] describe "maybeArray" $ do - it "Coalesces NULL into an empty array" $ run $ do + itDb "Coalesces NULL into an empty array" $ do [Value ret] <- select $ from $ \p -> return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName)) liftIO $ ret `shouldBe` [] - - - - -testPostgresModule :: Spec +testPostgresModule :: SpecDb testPostgresModule = do - describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do - prop "works" $ \listOfDateParts -> run $ do - let - utcTimes = - map - (\(y, m, d, s) -> - fromInteger s - `addUTCTime` - UTCTime (fromGregorian (2000 + y) m d) 0 - ) - listOfDateParts - truncateDate - :: SqlExpr (Value String) -- ^ .e.g (val "day") - -> SqlExpr (Value UTCTime) -- ^ input field - -> SqlExpr (Value UTCTime) -- ^ truncated date - truncateDate datePart expr = - ES.unsafeSqlFunction "date_trunc" (datePart, expr) - vals = - zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes - for_ vals $ \(idx, utcTime) -> do - insertKey idx (DateTruncTest utcTime) + describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do + propDb "works" $ \run listOfDateParts -> run $ do + let + utcTimes = + map + (\(y, m, d, s) -> + fromInteger s + `addUTCTime` + UTCTime (fromGregorian (2000 + y) m d) 0 + ) + listOfDateParts + truncateDate + :: SqlExpr (Value String) -- ^ .e.g (val "day") + -> SqlExpr (Value UTCTime) -- ^ input field + -> SqlExpr (Value UTCTime) -- ^ truncated date + truncateDate datePart expr = + ES.unsafeSqlFunction "date_trunc" (datePart, expr) + vals = + zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes + for_ vals $ \(idx, utcTime) -> do + insertKey idx (DateTruncTest utcTime) - -- Necessary to get the test to pass; see the discussion in - -- https://github.com/bitemyapp/esqueleto/pull/180 - rawExecute "SET TIME ZONE 'UTC'" [] - ret <- - fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $ - select $ - from $ \dt -> do - pure - ( dt ^. DateTruncTestId - , ( dt ^. DateTruncTestCreated - , truncateDate (val "day") (dt ^. DateTruncTestCreated) - ) - ) + -- Necessary to get the test to pass; see the discussion in + -- https://github.com/bitemyapp/esqueleto/pull/180 + rawExecute "SET TIME ZONE 'UTC'" [] + ret <- + fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $ + select $ + from $ \dt -> do + pure + ( dt ^. DateTruncTestId + , ( dt ^. DateTruncTestCreated + , truncateDate (val "day") (dt ^. DateTruncTestCreated) + ) + ) - liftIO $ for_ vals $ \(idx, utcTime) -> do - case Map.lookup idx ret of - Nothing -> - expectationFailure "index not found" - Just (original, truncated) -> do - utcTime `shouldBe` original - if utctDay utcTime == utctDay truncated - then - utctDay utcTime `shouldBe` utctDay truncated - else - -- use this if/else to get a better error message - utcTime `shouldBe` truncated + asserting $ for_ vals $ \(idx, utcTime) -> do + case Map.lookup idx ret of + Nothing -> + expectationFailure "index not found" + Just (original, truncated) -> do + utcTime `shouldBe` original + if utctDay utcTime == utctDay truncated + then + utctDay utcTime `shouldBe` utctDay truncated + else + -- use this if/else to get a better error message + utcTime `shouldBe` truncated - describe "PostgreSQL module" $ do - describe "Aggregate functions" testAggregateFunctions - it "chr looks sane" $ - run $ do - [Value (ret :: String)] <- select $ return (EP.chr (val 65)) - liftIO $ ret `shouldBe` "A" + describe "PostgreSQL module" $ do + describe "Aggregate functions" testAggregateFunctions + itDb "chr looks sane" $ do + [Value (ret :: String)] <- select $ return (EP.chr (val 65)) + liftIO $ ret `shouldBe` "A" - it "allows unit for functions" $ do - vals <- run $ do - let - fn :: SqlExpr (Value UTCTime) - fn = ES.unsafeSqlFunction "now" () - select $ pure fn - vals `shouldSatisfy` ((1 ==) . length) + itDb "allows unit for functions" $ do + let + fn :: SqlExpr (Value UTCTime) + fn = ES.unsafeSqlFunction "now" () + vals <- select $ pure fn + liftIO $ vals `shouldSatisfy` ((1 ==) . length) - it "works with now" $ - run $ do - nowDb <- select $ return EP.now_ - nowUtc <- liftIO getCurrentTime - let oneSecond = realToFrac (1 :: Double) + itDb "works with now" $ + do + nowDb <- select $ return EP.now_ + nowUtc <- liftIO getCurrentTime + let oneSecond = realToFrac (1 :: Double) - -- | Check the result is not null - liftIO $ nowDb `shouldSatisfy` (not . null) + -- | Check the result is not null + liftIO $ nowDb `shouldSatisfy` (not . null) - -- | Unpack the now value - let (Value now: _) = nowDb + -- | Unpack the now value + let (Value now: _) = nowDb - -- | Get the time diff and check it's less than a second - liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond) + -- | Get the time diff and check it's less than a second + liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond) -testJSONInsertions :: Spec +testJSONInsertions :: SpecDb testJSONInsertions = - describe "JSON Insertions" $ do - it "adds scalar values" $ do - run $ do - insertIt Null - insertIt $ Bool True - insertIt $ Number 1 - insertIt $ String "test" - it "adds arrays" $ do - run $ do - insertIt $ toJSON ([] :: [A.Value]) - insertIt $ toJSON [Number 1, Bool True, Null] - insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True] - it "adds objects" $ do - run $ do - insertIt $ object ["a" .= (1 :: Int), "b" .= False] - insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]] - where insertIt :: MonadIO m => A.Value -> SqlPersistT m () - insertIt = insert_ . Json . JSONB + describe "JSON Insertions" $ do + itDb "adds scalar values" $ do + insertIt Null + insertIt $ Bool True + insertIt $ Number 1 + insertIt $ String "test" + itDb "adds arrays" $ do + insertIt $ toJSON ([] :: [A.Value]) + insertIt $ toJSON [Number 1, Bool True, Null] + insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True] + itDb "adds objects" $ do + insertIt $ object ["a" .= (1 :: Int), "b" .= False] + insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]] + where + insertIt :: MonadIO m => A.Value -> SqlPersistT m () + insertIt = insert_ . Json . JSONB - -testJSONOperators :: Spec +testJSONOperators :: SpecDb testJSONOperators = describe "JSON Operators" $ do testArrowOperators testFilterOperators testConcatDeleteOperators -testArrowOperators :: Spec +testArrowOperators :: SpecDb testArrowOperators = describe "Arrow Operators" $ do testArrowJSONB @@ -608,67 +565,69 @@ testArrowOperators = testHashArrowJSONB testHashArrowText -testArrowJSONB :: Spec +testArrowJSONB :: SpecDb testArrowJSONB = - describe "Single Arrow (JSONB)" $ do - it "creates sane SQL" $ - createSaneSQL @JSONValue - (jsonbVal (object ["a" .= True]) ->. "a") - "SELECT (? -> ?)\nFROM \"Json\"\n" - [ PersistLiteralEscaped "{\"a\":true}" - , PersistText "a" ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [1 :: Int,2,3]] - createSaneSQL @JSONValue - (jsonbVal obj ->. "a" ->. 1) - "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n" - [ PersistLiteralEscaped "{\"a\":[1,2,3]}" - , PersistText "a" - , PersistInt64 1 ] - it "works as expected" $ run $ do - x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False) - y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True) - z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message") - liftIO $ length x `shouldBe` 1 - liftIO $ length y `shouldBe` 1 - liftIO $ length z `shouldBe` 1 + describe "Single Arrow (JSONB)" $ do + itDb "creates sane SQL" $ + createSaneSQL @JSONValue + (jsonbVal (object ["a" .= True]) ->. "a") + "SELECT (? -> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":true}" + , PersistText "a" + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [1 :: Int,2,3]] + createSaneSQL @JSONValue + (jsonbVal obj ->. "a" ->. 1) + "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":[1,2,3]}" + , PersistText "a" + , PersistInt64 1 ] + itDb "works as expected" $ do + x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False) + y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True) + z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message") + asserting $ do + length x `shouldBe` 1 + length y `shouldBe` 1 + length z `shouldBe` 1 -testArrowText :: Spec +testArrowText :: SpecDb testArrowText = - describe "Single Arrow (Text)" $ do - it "creates sane SQL" $ - createSaneSQL - (jsonbVal (object ["a" .= True]) ->>. "a") - "SELECT (? ->> ?)\nFROM \"Json\"\n" - [ PersistLiteralEscaped "{\"a\":true}" - , PersistText "a" ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [1 :: Int,2,3]] - createSaneSQL - (jsonbVal obj ->. "a" ->>. 1) - "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n" - [ PersistLiteralEscaped "{\"a\":[1,2,3]}" - , PersistText "a" - , PersistInt64 1 ] - it "works as expected" $ run $ do - x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false") - y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true") - z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message") - liftIO $ length x `shouldBe` 1 - liftIO $ length y `shouldBe` 1 - liftIO $ length z `shouldBe` 1 + describe "Single Arrow (Text)" $ do + itDb "creates sane SQL" $ + createSaneSQL + (jsonbVal (object ["a" .= True]) ->>. "a") + "SELECT (? ->> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":true}" + , PersistText "a" ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [1 :: Int,2,3]] + createSaneSQL + (jsonbVal obj ->. "a" ->>. 1) + "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":[1,2,3]}" + , PersistText "a" + , PersistInt64 1 ] + itDb "works as expected" $ do + x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false") + y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true") + z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message") + liftIO $ length x `shouldBe` 1 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 -testHashArrowJSONB :: Spec +testHashArrowJSONB :: SpecDb testHashArrowJSONB = describe "Double Arrow (JSONB)" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let list = ["a","b","c"] createSaneSQL @JSONValue (jsonbVal (object ["a" .= True]) #>. list) "SELECT (? #> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":true}" , persistTextArray list ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj #>. ["a","1"] #>. ["b"]) @@ -676,7 +635,7 @@ testHashArrowJSONB = [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","1"] , persistTextArray ["b"] ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v #>. ["a","b","c"] ==. jsonbVal (String "message") y <- selectJSONwhere $ \v -> v #>. ["1","a"] ==. jsonbVal (Number 3.14) z <- selectJSONwhere $ \v -> v #>. ["1"] #>. ["a"] ==. jsonbVal (Number 3.14) @@ -684,17 +643,17 @@ testHashArrowJSONB = liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 -testHashArrowText :: Spec +testHashArrowText :: SpecDb testHashArrowText = describe "Double Arrow (Text)" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let list = ["a","b","c"] createSaneSQL (jsonbVal (object ["a" .= True]) #>>. list) "SELECT (? #>> ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped "{\"a\":true}" , persistTextArray list ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj #>. ["a","1"] #>>. ["b"]) @@ -702,7 +661,7 @@ testHashArrowText = [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","1"] , persistTextArray ["b"] ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v #>>. ["a","b","c"] ==. just (val "message") y <- selectJSONwhere $ \v -> v #>>. ["1","a"] ==. just (val "3.14") z <- selectJSONwhere $ \v -> v #>. ["1"] #>>. ["a"] ==. just (val "3.14") @@ -711,18 +670,18 @@ testHashArrowText = liftIO $ length z `shouldBe` 1 -testFilterOperators :: Spec +testFilterOperators :: SpecDb testFilterOperators = - describe "Filter Operators" $ do - testInclusion - testQMark - testQMarkAny - testQMarkAll + describe "Filter Operators" $ do + testInclusion + testQMark + testQMarkAny + testQMarkAll -testInclusion :: Spec +testInclusion :: SpecDb testInclusion = do describe "@>" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL @@ -731,7 +690,7 @@ testInclusion = do [ PersistLiteralEscaped encoded , PersistLiteralEscaped "{\"a\":false}" ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @@ -741,7 +700,7 @@ testInclusion = do , PersistText "a" , PersistLiteralEscaped "{\"b\":true}" ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1) y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]]) z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14]) @@ -749,7 +708,7 @@ testInclusion = do liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 describe "<@" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL @@ -758,7 +717,7 @@ testInclusion = do [ PersistLiteralEscaped "{\"a\":false}" , PersistLiteralEscaped encoded ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] obj' = object ["b" .= True, "c" .= Null] encoded = BSL.toStrict $ encode obj' @@ -769,7 +728,7 @@ testInclusion = do , PersistText "a" , PersistLiteralEscaped encoded ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1]) y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null]) z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"]) @@ -777,10 +736,10 @@ testInclusion = do liftIO $ length y `shouldBe` 1 liftIO $ length z `shouldBe` 1 -testQMark :: Spec +testQMark :: SpecDb testQMark = do describe "Question Mark" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL @@ -789,7 +748,7 @@ testQMark = do [ PersistLiteralEscaped encoded , PersistText "a" ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @@ -799,7 +758,7 @@ testQMark = do , persistTextArray ["a","0"] , PersistText "b" ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSONwhere (JSON.?. "a") y <- selectJSONwhere (JSON.?. "test") z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b" @@ -807,10 +766,10 @@ testQMark = do liftIO $ length y `shouldBe` 2 liftIO $ length z `shouldBe` 1 -testQMarkAny :: Spec +testQMarkAny :: SpecDb testQMarkAny = do describe "Question Mark (Any)" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let obj = (object ["a" .= False, "b" .= True]) encoded = BSL.toStrict $ encode obj createSaneSQL @@ -819,7 +778,7 @@ testQMarkAny = do [ PersistLiteralEscaped encoded , persistTextArray ["a","c"] ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @@ -829,7 +788,7 @@ testQMarkAny = do , persistTextArray ["a","0"] , persistTextArray ["b","c"] ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSONwhere (?|. ["b","test"]) y <- selectJSONwhere (?|. ["a"]) z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"] @@ -839,10 +798,10 @@ testQMarkAny = do liftIO $ length z `shouldBe` 1 liftIO $ length w `shouldBe` 0 -testQMarkAll :: Spec +testQMarkAll :: SpecDb testQMarkAll = do describe "Question Mark (All)" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL @@ -851,7 +810,7 @@ testQMarkAll = do [ PersistLiteralEscaped encoded , persistTextArray ["a","c"] ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @@ -861,7 +820,7 @@ testQMarkAll = do , persistTextArray ["a","0"] , persistTextArray ["b","c"] ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSONwhere (?&. ["test"]) y <- selectJSONwhere (?&. ["a","b"]) z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"] @@ -871,7 +830,7 @@ testQMarkAll = do liftIO $ length z `shouldBe` 1 liftIO $ length w `shouldBe` 9 -testConcatDeleteOperators :: Spec +testConcatDeleteOperators :: SpecDb testConcatDeleteOperators = do describe "Concatenation Operator" testConcatenationOperator describe "Deletion Operators" $ do @@ -879,10 +838,10 @@ testConcatDeleteOperators = do testMinusOperatorV10 testHashMinusOperator -testConcatenationOperator :: Spec +testConcatenationOperator :: SpecDb testConcatenationOperator = do describe "Concatenation" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let objAB = object ["a" .= False, "b" .= True] objC = object ["c" .= Null] createSaneSQL @JSONValue @@ -892,7 +851,7 @@ testConcatenationOperator = do [ PersistLiteralEscaped $ BSL.toStrict $ encode objAB , PersistLiteralEscaped $ BSL.toStrict $ encode objC ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue @@ -902,7 +861,7 @@ testConcatenationOperator = do , PersistText "a" , PersistLiteralEscaped "[null]" ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (object []) where_ $ v JSON.||. jsonbVal (object ["x" .= True]) @@ -921,10 +880,10 @@ testConcatenationOperator = do liftIO $ length z `shouldBe` 2 liftIO $ length w `shouldBe` 7 -testMinusOperator :: Spec +testMinusOperator :: SpecDb testMinusOperator = describe "Minus Operator" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue @@ -933,7 +892,7 @@ testMinusOperator = [ PersistLiteralEscaped encoded , PersistText "a" ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue @@ -943,7 +902,7 @@ testMinusOperator = , PersistText "a" , PersistInt64 0 ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True]) @@ -966,10 +925,10 @@ testMinusOperator = ||. v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ f v -testMinusOperatorV10 :: Spec +testMinusOperatorV10 :: SpecDb testMinusOperatorV10 = do describe "Minus Operator (PSQL >= v10)" $ do - it "creates sane SQL" $ do + itDb "creates sane SQL" $ do let obj = object ["a" .= False, "b" .= True] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue @@ -978,7 +937,7 @@ testMinusOperatorV10 = do [ PersistLiteralEscaped encoded , persistTextArray ["a","b"] ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] encoded = BSL.toStrict $ encode obj createSaneSQL @JSONValue @@ -988,7 +947,7 @@ testMinusOperatorV10 = do , persistTextArray ["a","0"] , persistTextArray ["b"] ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"]) @@ -1010,16 +969,16 @@ testMinusOperatorV10 = do ||. v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ f v -testHashMinusOperator :: Spec +testHashMinusOperator :: SpecDb testHashMinusOperator = describe "Hash-Minus Operator" $ do - it "creates sane SQL" $ + itDb "creates sane SQL" $ createSaneSQL @JSONValue (jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"]) "SELECT (? #- ?)\nFROM \"Json\"\n" [ PersistLiteralEscaped (BSL.toStrict $ encode $ object ["a" .= False, "b" .= True]) , persistTextArray ["a"] ] - it "creates sane SQL (chained)" $ do + itDb "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" #-. ["0","b"]) @@ -1027,7 +986,7 @@ testHashMinusOperator = [ PersistLiteralEscaped (BSL.toStrict $ encode obj) , PersistText "a" , persistTextArray ["0","b"] ] - it "works as expected" $ run $ do + itDb "works as expected" $ do x <- selectJSON $ \v -> do where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) where_ $ v #-. ["1","a"] @>. jsonbVal (toJSON [object []]) @@ -1047,13 +1006,22 @@ testHashMinusOperator = where_ $ v @>. jsonbVal (object []) where_ $ f v -testInsertUniqueViolation :: Spec +testInsertUniqueViolation :: SpecDb testInsertUniqueViolation = - describe "Unique Violation on Insert" $ - it "Unique throws exception" $ run (do - _ <- insert u1 - _ <- insert u2 - insert u3) `shouldThrow` (==) exception + describe "Unique Violation on Insert" $ + itDb "Unique throws exception" $ do + eres <- + try $ do + _ <- insert u1 + _ <- insert u2 + insert u3 + liftIO $ case eres of + Left err | err == exception -> + pure () + _ -> + expectationFailure $ "Expected a SQL exception, got: " <> + show eres + where exception = SqlError { sqlState = "23505", @@ -1062,13 +1030,13 @@ testInsertUniqueViolation = sqlErrorDetail = "Key (value)=(0) already exists.", sqlErrorHint = ""} -testUpsert :: Spec +testUpsert :: SpecDb testUpsert = describe "Upsert test" $ do - it "Upsert can insert like normal" $ run $ do + itDb "Upsert can insert like normal" $ do u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] liftIO $ entityVal u1e `shouldBe` u1 - it "Upsert performs update on collision" $ run $ do + itDb "Upsert performs update on collision" $ do u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] liftIO $ entityVal u1e `shouldBe` u1 u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"] @@ -1076,10 +1044,10 @@ testUpsert = u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"] liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} -testInsertSelectWithConflict :: Spec +testInsertSelectWithConflict :: SpecDb testInsertSelectWithConflict = describe "insertSelectWithConflict test" $ do - it "Should do Nothing when no updates set" $ run $ do + itDb "Should do Nothing when no updates set" $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 @@ -1098,7 +1066,7 @@ testInsertSelectWithConflict = let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] liftIO $ map entityVal uniques1 `shouldBe` test liftIO $ map entityVal uniques2 `shouldBe` test - it "Should update a value if given an update on conflict" $ run $ do + itDb "Should update a value if given an update on conflict" $ do _ <- insert p1 _ <- insert p2 _ <- insert p3 @@ -1120,10 +1088,10 @@ testInsertSelectWithConflict = liftIO $ map entityVal uniques1 `shouldBe` test liftIO $ map entityVal uniques2 `shouldBe` test2 -testFilterWhere :: Spec +testFilterWhere :: SpecDb testFilterWhere = describe "filterWhere" $ do - it "adds a filter clause to count aggregation" $ run $ do + itDb "adds a filter clause to count aggregation" $ do -- Person "John" (Just 36) Nothing 1 _ <- insert p1 -- Person "Rachel" Nothing (Just 37) 2 @@ -1159,7 +1127,7 @@ testFilterWhere = ] :: [(Maybe Int, Int, Int)] ) - it "adds a filter clause to sum aggregation" $ run $ do + itDb "adds a filter clause to sum aggregation" $ do -- Person "John" (Just 36) Nothing 1 _ <- insert p1 -- Person "Rachel" Nothing (Just 37) 2 @@ -1193,27 +1161,46 @@ testFilterWhere = ] :: [(Maybe Int, Maybe Rational, Maybe Rational)] ) -testCommonTableExpressions :: Spec +testCommonTableExpressions :: SpecDb testCommonTableExpressions = do - describe "You can run them" $ do - it "will run" $ do - run $ do + describe "You can run them" $ do + itDb "will run" $ do + void $ select $ do + limitedLordsCte <- + Experimental.with $ do + lords <- Experimental.from $ Experimental.table @Lord + limit 10 + pure lords + lords <- Experimental.from limitedLordsCte + orderBy [asc $ lords ^. LordId] + pure lords - void $ select $ do - limitedLordsCte <- - Experimental.with $ do - lords <- Experimental.from $ Experimental.table @Lord - limit 10 - pure lords - lords <- Experimental.from limitedLordsCte - orderBy [asc $ lords ^. LordId] - pure lords + asserting noExceptions - True `shouldBe` True + itDb "can do multiple recursive queries" $ do + let + oneToTen = + Experimental.withRecursive + (pure $ val (1 :: Int)) + Experimental.unionAll_ + (\self -> do + v <- Experimental.from self + where_ $ v <. val 10 + pure $ v +. val 1 + ) - it "can do multiple recursive queries" $ do - vals <- run $ do - let oneToTen = Experimental.withRecursive + vals <- select $ do + cte <- oneToTen + cte2 <- oneToTen + res1 <- Experimental.from cte + res2 <- Experimental.from cte2 + pure (res1, res2) + asserting $ vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10])) + + itDb "passing previous query works" $ do + let + oneToTen = + Experimental.withRecursive (pure $ val (1 :: Int)) Experimental.unionAll_ (\self -> do @@ -1222,124 +1209,69 @@ testCommonTableExpressions = do pure $ v +. val 1 ) - select $ do - cte <- oneToTen - cte2 <- oneToTen - res1 <- Experimental.from cte - res2 <- Experimental.from cte2 - pure (res1, res2) - vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10])) - - it "passing previous query works" $ - let - oneToTen = - Experimental.withRecursive - (pure $ val (1 :: Int)) - Experimental.unionAll_ - (\self -> do - v <- Experimental.from self - where_ $ v <. val 10 - pure $ v +. val 1 - ) - - oneMore q = - Experimental.with $ do - v <- Experimental.from q - pure $ v +. val 1 - in do - vals <- run $ do - - select $ do - cte <- oneToTen - cte2 <- oneMore cte - res <- Experimental.from cte2 - pure res - vals `shouldBe` fmap Value [2..11] + oneMore q = + Experimental.with $ do + v <- Experimental.from q + pure $ v +. val 1 + vals <- select $ do + cte <- oneToTen + cte2 <- oneMore cte + res <- Experimental.from cte2 + pure res + asserting $ vals `shouldBe` fmap Value [2..11] -- Since lateral queries arent supported in Sqlite or older versions of mysql -- the test is in the Postgres module -testLateralQuery :: Spec +testLateralQuery :: SpecDb testLateralQuery = do - describe "Lateral queries" $ do - it "supports CROSS JOIN LATERAL" $ do - _ <- run $ do - select $ do - l :& c <- - Experimental.from $ table @Lord - `CrossJoin` \lord -> do - deed <- Experimental.from $ table @Deed - where_ $ lord ^. LordId ==. deed ^. DeedOwnerId - pure $ countRows @Int - pure (l, c) - True `shouldBe` True + describe "Lateral queries" $ do + itDb "supports CROSS JOIN LATERAL" $ do + _ <- do + select $ do + l :& c <- + Experimental.from $ table @Lord + `CrossJoin` \lord -> do + deed <- Experimental.from $ table @Deed + where_ $ lord ^. LordId ==. deed ^. DeedOwnerId + pure $ countRows @Int + pure (l, c) + liftIO $ True `shouldBe` True - it "supports INNER JOIN LATERAL" $ do - run $ do - let subquery lord = do - deed <- Experimental.from $ table @Deed - where_ $ lord ^. LordId ==. deed ^. DeedOwnerId - pure $ countRows @Int - res <- select $ do - l :& c <- Experimental.from $ table @Lord - `InnerJoin` subquery - `Experimental.on` (const $ val True) - pure (l, c) + itDb "supports INNER JOIN LATERAL" $ do + let subquery lord = do + deed <- Experimental.from $ table @Deed + where_ $ lord ^. LordId ==. deed ^. DeedOwnerId + pure $ countRows @Int + res <- select $ do + l :& c <- Experimental.from $ table @Lord + `InnerJoin` subquery + `Experimental.on` (const $ val True) + pure (l, c) - let _ = res :: [(Entity Lord, Value Int)] - pure () - True `shouldBe` True + let _ = res :: [(Entity Lord, Value Int)] + asserting noExceptions - it "supports LEFT JOIN LATERAL" $ do - run $ do - res <- select $ do - l :& c <- Experimental.from $ table @Lord - `LeftOuterJoin` (\lord -> do - deed <- Experimental.from $ table @Deed - where_ $ lord ^. LordId ==. deed ^. DeedOwnerId - pure $ countRows @Int) - `Experimental.on` (const $ val True) - pure (l, c) + itDb "supports LEFT JOIN LATERAL" $ do + res <- select $ do + l :& c <- Experimental.from $ table @Lord + `LeftOuterJoin` (\lord -> do + deed <- Experimental.from $ table @Deed + where_ $ lord ^. LordId ==. deed ^. DeedOwnerId + pure $ countRows @Int) + `Experimental.on` (const $ val True) + pure (l, c) - let _ = res :: [(Entity Lord, Value (Maybe Int))] - pure () - True `shouldBe` True - - {-- - it "compile error on RIGHT JOIN LATERAL" $ do - run $ do - res <- select $ do - l :& c <- Experimental.from $ table @Lord - `RightOuterJoin` (\lord -> do - deed <- Experimental.from $ table @Deed - where_ $ lord ?. LordId ==. just (deed ^. DeedOwnerId) - pure $ countRows @Int) - `Experimental.on` (const $ val True) - pure (l, c) - - let _ = res :: [(Maybe (Entity Lord), Value Int)] - pure () - it "compile error on FULL OUTER JOIN LATERAL" $ do - run $ do - res <- select $ do - l :& c <- Experimental.from $ table @Lord - `FullOuterJoin` (\lord -> do - deed <- Experimental.from $ table @Deed - where_ $ lord ?. LordId ==. just (deed ^. DeedOwnerId) - pure $ countRows @Int) - `Experimental.on` (const $ val True) - pure (l, c) - - let _ = res :: [(Maybe (Entity Lord), Value (Maybe Int))] - pure () - --} + let _ = res :: [(Entity Lord, Value (Maybe Int))] + asserting noExceptions type JSONValue = Maybe (JSONB A.Value) -createSaneSQL :: (PersistField a) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> IO () -createSaneSQL act q vals = run $ do +createSaneSQL :: (PersistField a, MonadIO m) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> SqlPersistT m () +createSaneSQL act q vals = do (query, args) <- showQuery ES.SELECT $ fromValue act - liftIO $ query `shouldBe` q - liftIO $ args `shouldBe` vals + liftIO $ do + query `shouldBe` q + args `shouldBe` vals fromValue :: (PersistField a) => SqlExpr (Value a) -> SqlQuery (SqlExpr (Value a)) fromValue act = from $ \x -> do @@ -1349,7 +1281,11 @@ fromValue act = from $ \x -> do persistTextArray :: [T.Text] -> PersistValue persistTextArray = PersistArray . fmap PersistText -sqlFailWith :: (HasCallStack, MonadCatch m, MonadIO m, Show a) => ByteString -> SqlPersistT (R.ResourceT m) a -> SqlPersistT (R.ResourceT m) () +sqlFailWith + :: (HasCallStack, MonadUnliftIO m, Show a) + => ByteString + -> SqlPersistT m a + -> SqlPersistT m () sqlFailWith errState f = do eres <- try f case eres of @@ -1395,15 +1331,12 @@ selectJSON f = select $ from $ \v -> do spec :: Spec -spec = do - tests run - - describe "Test PostgreSQL locking" $ do - testLocking withConn +spec = beforeAll mkConnectionPool $ do + tests describe "PostgreSQL specific tests" $ do - testAscRandom random_ run - testRandomMath run + testAscRandom random_ + testRandomMath testSelectDistinctOn testPostgresModule testPostgresqlOneAscOneDesc @@ -1418,63 +1351,62 @@ spec = do testInsertSelectWithConflict testFilterWhere testCommonTableExpressions - describe "PostgreSQL JSON tests" $ do - -- NOTE: We only clean the table once, so we - -- can use its contents across all JSON tests - it "MIGRATE AND CLEAN JSON TABLE" $ run $ do - void $ runMigrationSilent migrateJSON - cleanJSON - testJSONInsertions - testJSONOperators + setDatabaseState insertJsonValues cleanJSON + $ describe "PostgreSQL JSON tests" $ do + testJSONInsertions + testJSONOperators testLateralQuery -run, runSilent, runVerbose :: Run -runSilent act = runNoLoggingT $ run_worker act -runVerbose act = runStderrLoggingT $ run_worker act -run f = do - verbose' <- lookupEnv "VERBOSE" >>= \case - Nothing -> return verbose - Just x | map Char.toLower x == "true" -> return True - | null x -> return True - | otherwise -> return False - if verbose' - then runVerbose f - else runSilent f +insertJsonValues :: SqlPersistT IO () +insertJsonValues = do + insertIt Null + insertIt $ Bool True + insertIt $ Number 1 + insertIt $ String "test" + insertIt $ toJSON ([] :: [A.Value]) + insertIt $ toJSON [Number 1, Bool True, Null] + insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True] + insertIt $ object ["a" .= (1 :: Int), "b" .= False] + insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]] + where + insertIt :: MonadIO m => A.Value -> SqlPersistT m () + insertIt = insert_ . Json . JSONB verbose :: Bool verbose = False -run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a -run_worker act = withConn $ runSqlConn (migrateIt >> act) +migrateIt :: _ => SqlPersistT m () +migrateIt = mapReaderT runNoLoggingT $ do + void $ runMigrationSilent $ do + migrateAll + migrateUnique + migrateJSON + cleanDB + cleanUniques -migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) () -migrateIt = do - void $ runMigrationSilent migrateAll - void $ runMigrationSilent migrateUnique - cleanDB - cleanUniques - -withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a -withConn f = do - ea <- try go - case ea of - Left (SomeException se) -> do - ea' <- try go - case ea' of - Left (SomeException se1) -> - if show se == show se1 - then throwM se - else throwM se1 - Right a -> - pure a - Right a -> - pure a - where - go = - R.runResourceT $ - withPostgresqlConn - "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" - f +mkConnectionPool :: IO ConnectionPool +mkConnectionPool = do + verbose' <- lookupEnv "VERBOSE" >>= \case + Nothing -> + return verbose + Just x + | map Char.toLower x == "true" -> return True + | null x -> return True + | otherwise -> return False + pool <- if verbose' + then + runStderrLoggingT $ + createPostgresqlPool + "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" + 4 + else + runNoLoggingT $ + createPostgresqlPool + "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" + 4 + flip runSqlPool pool $ do + migrateIt + pure pool -- | Show the SQL generated by a query showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend) diff --git a/test/SQLite/Test.hs b/test/SQLite/Test.hs index 7eb32b2..79818ee 100644 --- a/test/SQLite/Test.hs +++ b/test/SQLite/Test.hs @@ -6,171 +6,135 @@ module SQLite.Test where +import Common.Test.Import hiding (from, on) + import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Control.Monad.Trans.Resource as R -import Database.Esqueleto hiding (random_) +import Database.Esqueleto.Legacy hiding (random_) import Database.Esqueleto.SQLite (random_) -import Database.Persist.Sqlite (withSqliteConn) +import Database.Persist.Sqlite (createSqlitePool) import Database.Sqlite (SqliteException) -import Test.Hspec import Common.Test -testSqliteRandom :: Spec +testSqliteRandom :: SpecDb testSqliteRandom = do - it "works with random_" $ - run $ do - _ <- select $ return (random_ :: SqlExpr (Value Int)) - return () + itDb "works with random_" $ do + _ <- select $ return (random_ :: SqlExpr (Value Int)) + asserting noExceptions - - - - -testSqliteSum :: Spec +testSqliteSum :: SpecDb testSqliteSum = do - it "works with sum_" $ - run $ do - _ <- insert' p1 - _ <- insert' p2 - _ <- insert' p3 - _ <- insert' p4 - ret <- select $ - from $ \p-> - return $ joinV $ sum_ (p ^. PersonAge) - liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ] + itDb "works with sum_" $ do + _ <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + _ <- insert' p4 + ret <- select $ + from $ \p-> + return $ joinV $ sum_ (p ^. PersonAge) + asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ] -testSqliteTwoAscFields :: Spec +testSqliteTwoAscFields :: SpecDb testSqliteTwoAscFields = do - it "works with two ASC fields (one call)" $ - run $ do - p1e <- insert' p1 - p2e <- insert' p2 - p3e <- insert' p3 - p4e <- insert' p4 - ret <- select $ - from $ \p -> do - orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] - return p - -- in SQLite and MySQL, its the reverse - liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] + itDb "works with two ASC fields (one call)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] + return p + -- in SQLite and MySQL, its the reverse + asserting $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] - - - - -testSqliteOneAscOneDesc :: Spec +testSqliteOneAscOneDesc :: SpecDb testSqliteOneAscOneDesc = do - it "works with one ASC and one DESC field (two calls)" $ - run $ do - p1e <- insert' p1 - p2e <- insert' p2 - p3e <- insert' p3 - p4e <- insert' p4 - ret <- select $ - from $ \p -> do - orderBy [desc (p ^. PersonAge)] - orderBy [asc (p ^. PersonName)] - return p - liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] + itDb "works with one ASC and one DESC field (two calls)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [desc (p ^. PersonAge)] + orderBy [asc (p ^. PersonName)] + return p + asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] - - - - -testSqliteCoalesce :: Spec +testSqliteCoalesce :: SpecDb testSqliteCoalesce = do - it "throws an exception on SQLite with <2 arguments" $ - run (select $ - from $ \p -> do - return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int)))) - `shouldThrow` (\(_ :: SqliteException) -> True) + itDb "throws an exception on SQLite with <2 arguments" $ do + eres <- try $ select $ + from $ \p -> do + return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int))) + asserting $ case eres of + Left (_ :: SqliteException) -> + pure () + Right _ -> + expectationFailure "Expected SqliteException with <2 args to coalesce" - - - - -testSqliteUpdate :: Spec +testSqliteUpdate :: SpecDb testSqliteUpdate = do - it "works on a simple example" $ - run $ do - p1k <- insert p1 - p2k <- insert p2 - p3k <- insert p3 - let anon = "Anonymous" - () <- update $ \p -> do - set p [ PersonName =. val anon - , PersonAge *=. just (val 2) ] - where_ (p ^. PersonName !=. val "Mike") - n <- updateCount $ \p -> do - set p [ PersonAge +=. just (val 1) ] - where_ (p ^. PersonName !=. val "Mike") - ret <- select $ - from $ \p -> do - orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] - return p - -- SQLite: nulls appear first, update returns matched rows. - liftIO $ n `shouldBe` 2 - liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2) - , Entity p1k (Person anon (Just 73) Nothing 1) - , Entity p3k p3 ] + itDb "works on a simple example" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + let anon = "Anonymous" :: String + () <- update $ \p -> do + set p [ PersonName =. val anon + , PersonAge *=. just (val 2) ] + where_ (p ^. PersonName !=. val "Mike") + n <- updateCount $ \p -> do + set p [ PersonAge +=. just (val 1) ] + where_ (p ^. PersonName !=. val "Mike") + ret <- select $ + from $ \p -> do + orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] + return p + -- SQLite: nulls appear first, update returns matched rows. + asserting $ do + n `shouldBe` 2 + ret `shouldMatchList` + [ Entity p2k (Person anon Nothing (Just 37) 2) + , Entity p1k (Person anon (Just 73) Nothing 1) + , Entity p3k p3 + ] - - - - -nameContains :: (BaseBackend backend ~ SqlBackend, - BackendCompatible SqlBackend backend, - MonadIO m, SqlString s, - IsPersistBackend backend, PersistQueryRead backend, - PersistUniqueRead backend) - => (SqlExpr (Value [Char]) - -> SqlExpr (Value s) - -> SqlExpr (Value Bool)) - -> s - -> [Entity Person] - -> ReaderT backend m () -nameContains f t expected = do - ret <- select $ - from $ \p -> do - where_ (f - (p ^. PersonName) - ((%) ++. val t ++. (%))) - orderBy [asc (p ^. PersonName)] - return p - liftIO $ ret `shouldBe` expected - -testSqliteTextFunctions :: Spec +testSqliteTextFunctions :: SpecDb testSqliteTextFunctions = do - describe "text functions" $ do - it "like, (%) and (++.) work on a simple example" $ - run $ do - [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] - nameContains like "h" [p1e, p2e] - nameContains like "i" [p4e, p3e] - nameContains like "iv" [p4e] + describe "text functions" $ do + itDb "like, (%) and (++.) work on a simple example" $ do + let query :: String -> SqlPersistT IO [Entity Person] + query t = + select $ + from $ \p -> do + where_ (like + (p ^. PersonName) + ((%) ++. val t ++. (%))) + orderBy [asc (p ^. PersonName)] + return p + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + r0 <- query "h" + r1 <- query "i" + r2 <- query "iv" + asserting $ do + r0 `shouldBe` [p1e, p2e] + r1 `shouldBe` [p4e, p3e] + r2 `shouldBe` [p4e] -main :: IO () -main = do - hspec spec - -spec :: Spec -spec = do - tests run - - describe "Test SQLite locking" $ do - testLocking withConn +spec :: HasCallStack => Spec +spec = beforeAll mkConnectionPool $ do + tests describe "SQLite specific tests" $ do - testAscRandom random_ run - testRandomMath run + testAscRandom random_ + testRandomMath testSqliteRandom testSqliteSum testSqliteTwoAscFields @@ -179,24 +143,23 @@ spec = do testSqliteUpdate testSqliteTextFunctions -run, runSilent, runVerbose :: Run -runSilent act = runNoLoggingT $ run_worker act -runVerbose act = runStderrLoggingT $ run_worker act -run = - if verbose - then runVerbose - else runSilent +mkConnectionPool :: IO ConnectionPool +mkConnectionPool = do + conn <- + if verbose + then runStderrLoggingT $ + createSqlitePool ".esqueleto-test.sqlite" 4 + else runNoLoggingT $ + createSqlitePool ".esqueleto-test.sqlite" 4 + flip runSqlPool conn $ do + migrateIt + + pure conn verbose :: Bool verbose = False -run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a -run_worker act = withConn $ runSqlConn (migrateIt >> act) - -migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) () +migrateIt :: MonadUnliftIO m => SqlPersistT m () migrateIt = do void $ runMigrationSilent migrateAll - -withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a -withConn = - R.runResourceT . withSqliteConn ":memory:" + cleanDB