diff --git a/esqueleto.cabal b/esqueleto.cabal index b5d3fed..bca865b 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -80,105 +80,49 @@ library -Wmonomorphism-restriction default-language: Haskell2010 -test-suite mysql +test-suite specs type: exitcode-stdio-1.0 - main-is: MySQL/Test.hs - other-modules: - Common.Test - Paths_esqueleto - hs-source-dirs: - test - ghc-options: -Wall - build-depends: - base >=4.8 && <5.0 - , attoparsec - , blaze-html - , bytestring - , conduit >=1.3 - , containers - , esqueleto - , exceptions - , hspec - , monad-logger - , mtl - , mysql - , mysql-simple - , persistent - , persistent-mysql - , resourcet >=1.2 - , tagged >=0.2 - , text >=0.11 && <1.3 - , time - , transformers >=0.2 - , unliftio - , unordered-containers >=0.2 - default-language: Haskell2010 - -test-suite postgresql - type: exitcode-stdio-1.0 - main-is: PostgreSQL/Test.hs + main-is: Spec.hs other-modules: Common.Test + Common.Test.Models + Common.Test.Import + Common.Test.Select PostgreSQL.MigrateJSON - Paths_esqueleto + SQLite.Test + PostgreSQL.Test + MySQL.Test + default-extensions: + RankNTypes hs-source-dirs: test ghc-options: -Wall -threaded build-depends: base >=4.8 && <5.0 , aeson - , attoparsec - , blaze-html - , bytestring - , conduit >=1.3 - , containers - , esqueleto - , exceptions - , hspec - , monad-logger - , mtl - , persistent - , persistent-postgresql - , postgresql-libpq , postgresql-simple - , resourcet >=1.2 - , tagged >=0.2 - , text >=0.11 && <1.3 - , time - , transformers >=0.2 - , unliftio - , unordered-containers >=0.2 - , vector - default-language: Haskell2010 - -test-suite sqlite - type: exitcode-stdio-1.0 - main-is: SQLite/Test.hs - other-modules: - Common.Test - Paths_esqueleto - hs-source-dirs: - test - ghc-options: -Wall -threaded - build-depends: - base >=4.8 && <5.0 , attoparsec , blaze-html , bytestring - , conduit >=1.3 + , conduit , containers , esqueleto , exceptions , hspec + , hspec-core , monad-logger , mtl + , mysql + , mysql-simple , persistent + , persistent-mysql , persistent-sqlite - , resourcet >=1.2 - , tagged >=0.2 - , text >=0.11 && <1.3 + , persistent-postgresql + , resourcet + , tagged + , text , time - , transformers >=0.2 + , transformers , unliftio - , unordered-containers >=0.2 + , unordered-containers default-language: Haskell2010 diff --git a/test/Common/Test.hs b/test/Common/Test.hs index a692e20..deed118 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -64,6 +64,8 @@ module Common.Test , Key(..) ) where +import Common.Test.Import hiding (from, on) + import Control.Monad (forM_, replicateM, replicateM_, void) import Control.Monad.Catch (MonadCatch) import Control.Monad.Reader (ask) @@ -73,7 +75,8 @@ import Data.Time import Control.Monad.Fail (MonadFail) #endif import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Logger (MonadLoggerIO(..), MonadLogger(..), NoLoggingT, runNoLoggingT) +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) @@ -96,167 +99,9 @@ import qualified Database.Esqueleto.Internal.ExprParser as P import qualified Database.Esqueleto.Internal.Internal as EI import qualified UnliftIO.Resource as R +import Common.Test.Select + -- Test schema -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| - Foo - name Int - Primary name - deriving Show Eq Ord - Bar - quux FooId - deriving Show Eq Ord - Baz - blargh FooId - deriving Show Eq - Shoop - baz BazId - deriving Show Eq - Asdf - shoop ShoopId - deriving Show Eq - Another - why BazId - YetAnother - argh ShoopId - - Person - name String - age Int Maybe - weight Int Maybe - favNum Int - deriving Eq Show Ord - BlogPost - title String - authorId PersonId - deriving Eq Show - Comment - body String - blog BlogPostId - deriving Eq Show - CommentReply - body String - comment CommentId - Profile - name String - person PersonId - deriving Eq Show - Reply - guy PersonId - body String - deriving Eq Show - - Lord - county String maxlen=100 - dogs Int Maybe - Primary county - deriving Eq Show - - Deed - contract String maxlen=100 - ownerId LordId maxlen=100 - Primary contract - deriving Eq Show - - Follow - follower PersonId - followed PersonId - deriving Eq Show - - CcList - names [String] - - Frontcover - number Int - title String - Primary number - deriving Eq Show - Article - title String - frontcoverNumber Int - Foreign Frontcover fkfrontcover frontcoverNumber - deriving Eq Show - ArticleMetadata - articleId ArticleId - Primary articleId - deriving Eq Show - Tag - name String maxlen=100 - Primary name - deriving Eq Show - ArticleTag - articleId ArticleId - tagId TagId maxlen=100 - Primary articleId tagId - deriving Eq Show - Article2 - title String - frontcoverId FrontcoverId - deriving Eq Show - Point - x Int - y Int - name String - Primary x y - deriving Eq Show - Circle - centerX Int - centerY Int - name String - Foreign Point fkpoint centerX centerY - deriving Eq Show - Numbers - int Int - double Double - deriving Eq Show - - JoinOne - name String - deriving Eq Show - - JoinTwo - joinOne JoinOneId - name String - deriving Eq Show - - JoinThree - joinTwo JoinTwoId - name String - deriving Eq Show - - JoinFour - name String - joinThree JoinThreeId - deriving Eq Show - - JoinOther - name String - deriving Eq Show - - JoinMany - name String - joinOther JoinOtherId - joinOne JoinOneId - deriving Eq Show - - DateTruncTest - created UTCTime - deriving Eq Show -|] - --- Unique Test schema -share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase| - OneUnique - name String - value Int - UniqueValue value - deriving Eq Show -|] - - -instance ToBaseId ArticleMetadata where - type BaseEnt ArticleMetadata = Article - toBaseIdWitness articleId = ArticleMetadataKey articleId - -- | this could be achieved with S.fromList, but not all lists -- have Ord instances sameElementsAs :: Eq a => [a] -> [a] -> Bool @@ -305,29 +150,6 @@ u3 = OneUnique "Third" 0 u4 :: OneUnique u4 = OneUnique "First" 2 -testSelect :: Run -> Spec -testSelect run = do - describe "select" $ do - it "works for a single value" $ - run $ do - ret <- select $ return $ val (3 :: Int) - liftIO $ 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, ()) ] - - it "works for a single ()" $ - run $ do - ret <- select $ return () - liftIO $ ret `shouldBe` [ () ] - - it "works for a single NULL value" $ - run $ do - ret <- select $ return nothing - liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ] - testSubSelect :: Run -> Spec testSubSelect run = do let setup :: MonadIO m => SqlPersistT m () @@ -2463,28 +2285,28 @@ listsEqualOn a b f = map f a `shouldBe` map f b tests :: Run -> Spec tests run = do - describe "Tests that are common to all backends" $ 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 + 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 insert' :: ( Functor m @@ -2496,20 +2318,6 @@ insert' :: ( Functor m insert' v = flip Entity v <$> insert v -type RunDbMonad m = ( MonadUnliftIO m - , MonadIO m - , MonadLoggerIO m - , MonadLogger m - , MonadCatch m ) - -#if __GLASGOW_HASKELL__ >= 806 -type Run = forall a. (forall m. (RunDbMonad m, MonadFail m) => SqlPersistT (R.ResourceT m) a) -> IO a -#else -type Run = forall a. (forall m. (RunDbMonad m) => SqlPersistT (R.ResourceT m) a) -> IO a -#endif - -type WithConn m a = RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a - -- With SQLite and in-memory databases, a separate connection implies a -- separate database. With 'actual databases', the data is persistent and -- thus must be cleaned after each test. diff --git a/test/Common/Test/Import.hs b/test/Common/Test/Import.hs new file mode 100644 index 0000000..61af32f --- /dev/null +++ b/test/Common/Test/Import.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Common.Test.Import + ( module Common.Test.Import + , module X + ) where + +import Control.Monad.Fail +import Common.Test.Models as X +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Logger (MonadLogger(..), MonadLoggerIO(..)) +import Database.Esqueleto.Experimental as X +import Test.Hspec as X +import UnliftIO as X +import qualified UnliftIO.Resource as R + +type RunDbMonad m = + ( MonadUnliftIO m + , MonadIO m + , MonadLoggerIO m + , MonadLogger m + , MonadCatch m + ) + +type Run = forall a. (forall m. (RunDbMonad m, MonadFail m) => SqlPersistT (R.ResourceT m) a) -> IO a + +type WithConn m a = RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a diff --git a/test/Common/Test/Models.hs b/test/Common/Test/Models.hs new file mode 100644 index 0000000..cdf9679 --- /dev/null +++ b/test/Common/Test/Models.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Common.Test.Models where + +import Data.Time +import Database.Esqueleto.Experimental +import Database.Persist.Sql +import Database.Persist.TH + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| + Foo + name Int + Primary name + deriving Show Eq Ord + Bar + quux FooId + deriving Show Eq Ord + Baz + blargh FooId + deriving Show Eq + Shoop + baz BazId + deriving Show Eq + Asdf + shoop ShoopId + deriving Show Eq + Another + why BazId + YetAnother + argh ShoopId + + Person + name String + age Int Maybe + weight Int Maybe + favNum Int + deriving Eq Show Ord + BlogPost + title String + authorId PersonId + deriving Eq Show + Comment + body String + blog BlogPostId + deriving Eq Show + CommentReply + body String + comment CommentId + Profile + name String + person PersonId + deriving Eq Show + Reply + guy PersonId + body String + deriving Eq Show + + Lord + county String maxlen=100 + dogs Int Maybe + Primary county + deriving Eq Show + + Deed + contract String maxlen=100 + ownerId LordId maxlen=100 + Primary contract + deriving Eq Show + + Follow + follower PersonId + followed PersonId + deriving Eq Show + + CcList + names [String] + + Frontcover + number Int + title String + Primary number + deriving Eq Show + Article + title String + frontcoverNumber Int + Foreign Frontcover fkfrontcover frontcoverNumber + deriving Eq Show + ArticleMetadata + articleId ArticleId + Primary articleId + deriving Eq Show + Tag + name String maxlen=100 + Primary name + deriving Eq Show + ArticleTag + articleId ArticleId + tagId TagId maxlen=100 + Primary articleId tagId + deriving Eq Show + Article2 + title String + frontcoverId FrontcoverId + deriving Eq Show + Point + x Int + y Int + name String + Primary x y + deriving Eq Show + Circle + centerX Int + centerY Int + name String + Foreign Point fkpoint centerX centerY + deriving Eq Show + Numbers + int Int + double Double + deriving Eq Show + + JoinOne + name String + deriving Eq Show + + JoinTwo + joinOne JoinOneId + name String + deriving Eq Show + + JoinThree + joinTwo JoinTwoId + name String + deriving Eq Show + + JoinFour + name String + joinThree JoinThreeId + deriving Eq Show + + JoinOther + name String + deriving Eq Show + + JoinMany + name String + joinOther JoinOtherId + joinOne JoinOneId + deriving Eq Show + + DateTruncTest + created UTCTime + deriving Eq Show +|] + +-- Unique Test schema +share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase| + OneUnique + name String + value Int + UniqueValue value + deriving Eq Show +|] + + +instance ToBaseId ArticleMetadata where + type BaseEnt ArticleMetadata = Article + toBaseIdWitness articleId = ArticleMetadataKey articleId + diff --git a/test/Common/Test/Select.hs b/test/Common/Test/Select.hs new file mode 100644 index 0000000..14fbd87 --- /dev/null +++ b/test/Common/Test/Select.hs @@ -0,0 +1,26 @@ +module Common.Test.Select where + +import Common.Test.Import + +testSelect :: Run -> Spec +testSelect run = do + describe "select" $ do + it "works for a single value" $ + run $ do + ret <- select $ return $ val (3 :: Int) + liftIO $ 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, ()) ] + + it "works for a single ()" $ + run $ do + ret <- select $ return () + liftIO $ ret `shouldBe` [ () ] + + it "works for a single NULL value" $ + run $ do + ret <- select $ return nothing + liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ] diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index 20e5e1a..5fb72a4 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module MySQL.Test where import Control.Applicative import Control.Monad (void) @@ -194,28 +194,23 @@ testMysqlUnionWithLimits = do ret <- select $ Experimental.from $ q1 `union_` q2 liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5] - -main :: IO () -main = do - hspec $ do +spec :: Spec +spec = do tests run describe "Test MySQL locking" $ do - testLocking withConn + testLocking withConn describe "MySQL specific tests" $ do - -- definitely doesn't work at the moment - -- testMysqlRandom - testMysqlSum - testMysqlTwoAscFields - testMysqlOneAscOneDesc - testMysqlCoalesce - testMysqlUpdate - testMysqlTextFunctions - testMysqlUnionWithLimits - - - + -- definitely doesn't work at the moment + -- testMysqlRandom + testMysqlSum + testMysqlTwoAscFields + testMysqlOneAscOneDesc + testMysqlCoalesce + testMysqlUpdate + testMysqlTextFunctions + testMysqlUnionWithLimits run, runSilent, runVerbose :: Run runSilent act = runNoLoggingT $ run_worker act diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index c991705..9783986 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -8,7 +8,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where + +module PostgreSQL.Test where import Control.Arrow ((&&&)) import Control.Monad (void, when) @@ -1393,40 +1394,39 @@ selectJSON f = select $ from $ \v -> do -main :: IO () -main = do - hspec $ do - tests run +spec :: Spec +spec = do + tests run - describe "Test PostgreSQL locking" $ do - testLocking withConn + describe "Test PostgreSQL locking" $ do + testLocking withConn - describe "PostgreSQL specific tests" $ do - testAscRandom random_ run - testRandomMath run - testSelectDistinctOn - testPostgresModule - testPostgresqlOneAscOneDesc - testPostgresqlTwoAscFields - testPostgresqlSum - testPostgresqlRandom - testPostgresqlUpdate - testPostgresqlCoalesce - testPostgresqlTextFunctions - testInsertUniqueViolation - testUpsert - 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 - testLateralQuery + describe "PostgreSQL specific tests" $ do + testAscRandom random_ run + testRandomMath run + testSelectDistinctOn + testPostgresModule + testPostgresqlOneAscOneDesc + testPostgresqlTwoAscFields + testPostgresqlSum + testPostgresqlRandom + testPostgresqlUpdate + testPostgresqlCoalesce + testPostgresqlTextFunctions + testInsertUniqueViolation + testUpsert + 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 + testLateralQuery run, runSilent, runVerbose :: Run runSilent act = runNoLoggingT $ run_worker act diff --git a/test/SQLite/Test.hs b/test/SQLite/Test.hs index c124986..7eb32b2 100644 --- a/test/SQLite/Test.hs +++ b/test/SQLite/Test.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Main (main) where +module SQLite.Test where import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) @@ -19,9 +19,6 @@ import Test.Hspec import Common.Test - - - testSqliteRandom :: Spec testSqliteRandom = do it "works with random_" $ @@ -162,7 +159,10 @@ testSqliteTextFunctions = do main :: IO () main = do - hspec $ do + hspec spec + +spec :: Spec +spec = do tests run describe "Test SQLite locking" $ do diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..f6201f1 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,22 @@ +module Main where + +import Test.Hspec +import Test.Hspec.Core.Spec + +import qualified SQLite.Test as SQLite +import qualified MySQL.Test as MySQL +import qualified PostgreSQL.Test as Postgres + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + parallel $ describe "Esqueleto" $ do + describe "SQLite" $ do + sequential $ SQLite.spec + describe "MySQL" $ do + sequential $ MySQL.spec + describe "Postgresql" $ do + sequential $ Postgres.spec +