Consolidate Tests (#261)

* Consolidate Tests

* stylish-haskell

* woops

* lol
This commit is contained in:
Matt Parsons 2021-05-27 14:38:02 -06:00 committed by GitHub
parent b295bc6a5f
commit e145be999a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 384 additions and 353 deletions

View File

@ -80,105 +80,49 @@ library
-Wmonomorphism-restriction -Wmonomorphism-restriction
default-language: Haskell2010 default-language: Haskell2010
test-suite mysql test-suite specs
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: MySQL/Test.hs main-is: Spec.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
other-modules: other-modules:
Common.Test Common.Test
Common.Test.Models
Common.Test.Import
Common.Test.Select
PostgreSQL.MigrateJSON PostgreSQL.MigrateJSON
Paths_esqueleto SQLite.Test
PostgreSQL.Test
MySQL.Test
default-extensions:
RankNTypes
hs-source-dirs: hs-source-dirs:
test test
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
build-depends: build-depends:
base >=4.8 && <5.0 base >=4.8 && <5.0
, aeson , aeson
, attoparsec
, blaze-html
, bytestring
, conduit >=1.3
, containers
, esqueleto
, exceptions
, hspec
, monad-logger
, mtl
, persistent
, persistent-postgresql
, postgresql-libpq
, postgresql-simple , 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 , attoparsec
, blaze-html , blaze-html
, bytestring , bytestring
, conduit >=1.3 , conduit
, containers , containers
, esqueleto , esqueleto
, exceptions , exceptions
, hspec , hspec
, hspec-core
, monad-logger , monad-logger
, mtl , mtl
, mysql
, mysql-simple
, persistent , persistent
, persistent-mysql
, persistent-sqlite , persistent-sqlite
, resourcet >=1.2 , persistent-postgresql
, tagged >=0.2 , resourcet
, text >=0.11 && <1.3 , tagged
, text
, time , time
, transformers >=0.2 , transformers
, unliftio , unliftio
, unordered-containers >=0.2 , unordered-containers
default-language: Haskell2010 default-language: Haskell2010

View File

@ -64,6 +64,8 @@ module Common.Test
, Key(..) , Key(..)
) where ) where
import Common.Test.Import hiding (from, on)
import Control.Monad (forM_, replicateM, replicateM_, void) import Control.Monad (forM_, replicateM, replicateM_, void)
import Control.Monad.Catch (MonadCatch) import Control.Monad.Catch (MonadCatch)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
@ -73,7 +75,8 @@ import Data.Time
import Control.Monad.Fail (MonadFail) import Control.Monad.Fail (MonadFail)
#endif #endif
import Control.Monad.IO.Class (MonadIO(liftIO)) 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 Control.Monad.Trans.Reader (ReaderT)
import qualified Data.Attoparsec.Text as AP import qualified Data.Attoparsec.Text as AP
import Data.Char (toLower, toUpper) 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 Database.Esqueleto.Internal.Internal as EI
import qualified UnliftIO.Resource as R import qualified UnliftIO.Resource as R
import Common.Test.Select
-- Test schema -- 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 -- | this could be achieved with S.fromList, but not all lists
-- have Ord instances -- have Ord instances
sameElementsAs :: Eq a => [a] -> [a] -> Bool sameElementsAs :: Eq a => [a] -> [a] -> Bool
@ -305,29 +150,6 @@ u3 = OneUnique "Third" 0
u4 :: OneUnique u4 :: OneUnique
u4 = OneUnique "First" 2 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 -> Spec
testSubSelect run = do testSubSelect run = do
let setup :: MonadIO m => SqlPersistT m () 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 -> Spec
tests run = do tests run = do
describe "Tests that are common to all backends" $ do describe "Esqueleto" $ do
testSelect run testSelect run
testSubSelect run testSubSelect run
testSelectSource run testSelectSource run
testSelectFrom run testSelectFrom run
testSelectJoin run testSelectJoin run
testSelectSubQuery run testSelectSubQuery run
testSelectWhere run testSelectWhere run
testSelectOrderBy run testSelectOrderBy run
testSelectDistinct run testSelectDistinct run
testCoasleceDefault run testCoasleceDefault run
testDelete run testDelete run
testUpdate run testUpdate run
testListOfValues run testListOfValues run
testListFields run testListFields run
testInsertsBySelect run testInsertsBySelect run
testMathFunctions run testMathFunctions run
testCase run testCase run
testCountingRows run testCountingRows run
testRenderSql run testRenderSql run
testOnClauseOrder run testOnClauseOrder run
testExperimentalFrom run testExperimentalFrom run
insert' :: ( Functor m insert' :: ( Functor m
@ -2496,20 +2318,6 @@ insert' :: ( Functor m
insert' v = flip Entity v <$> insert v 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 -- With SQLite and in-memory databases, a separate connection implies a
-- separate database. With 'actual databases', the data is persistent and -- separate database. With 'actual databases', the data is persistent and
-- thus must be cleaned after each test. -- thus must be cleaned after each test.

View File

@ -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

189
test/Common/Test/Models.hs Normal file
View File

@ -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

View File

@ -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) ]

View File

@ -4,7 +4,7 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Main (main) where module MySQL.Test where
import Control.Applicative import Control.Applicative
import Control.Monad (void) import Control.Monad (void)
@ -194,28 +194,23 @@ testMysqlUnionWithLimits = do
ret <- select $ Experimental.from $ q1 `union_` q2 ret <- select $ Experimental.from $ q1 `union_` q2
liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5] liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5]
spec :: Spec
main :: IO () spec = do
main = do
hspec $ do
tests run tests run
describe "Test MySQL locking" $ do describe "Test MySQL locking" $ do
testLocking withConn testLocking withConn
describe "MySQL specific tests" $ do describe "MySQL specific tests" $ do
-- definitely doesn't work at the moment -- definitely doesn't work at the moment
-- testMysqlRandom -- testMysqlRandom
testMysqlSum testMysqlSum
testMysqlTwoAscFields testMysqlTwoAscFields
testMysqlOneAscOneDesc testMysqlOneAscOneDesc
testMysqlCoalesce testMysqlCoalesce
testMysqlUpdate testMysqlUpdate
testMysqlTextFunctions testMysqlTextFunctions
testMysqlUnionWithLimits testMysqlUnionWithLimits
run, runSilent, runVerbose :: Run run, runSilent, runVerbose :: Run
runSilent act = runNoLoggingT $ run_worker act runSilent act = runNoLoggingT $ run_worker act

View File

@ -8,7 +8,8 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Main (main) where
module PostgreSQL.Test where
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Control.Monad (void, when) import Control.Monad (void, when)
@ -1393,40 +1394,39 @@ selectJSON f = select $ from $ \v -> do
main :: IO () spec :: Spec
main = do spec = do
hspec $ do tests run
tests run
describe "Test PostgreSQL locking" $ do describe "Test PostgreSQL locking" $ do
testLocking withConn testLocking withConn
describe "PostgreSQL specific tests" $ do describe "PostgreSQL specific tests" $ do
testAscRandom random_ run testAscRandom random_ run
testRandomMath run testRandomMath run
testSelectDistinctOn testSelectDistinctOn
testPostgresModule testPostgresModule
testPostgresqlOneAscOneDesc testPostgresqlOneAscOneDesc
testPostgresqlTwoAscFields testPostgresqlTwoAscFields
testPostgresqlSum testPostgresqlSum
testPostgresqlRandom testPostgresqlRandom
testPostgresqlUpdate testPostgresqlUpdate
testPostgresqlCoalesce testPostgresqlCoalesce
testPostgresqlTextFunctions testPostgresqlTextFunctions
testInsertUniqueViolation testInsertUniqueViolation
testUpsert testUpsert
testInsertSelectWithConflict testInsertSelectWithConflict
testFilterWhere testFilterWhere
testCommonTableExpressions testCommonTableExpressions
describe "PostgreSQL JSON tests" $ do describe "PostgreSQL JSON tests" $ do
-- NOTE: We only clean the table once, so we -- NOTE: We only clean the table once, so we
-- can use its contents across all JSON tests -- can use its contents across all JSON tests
it "MIGRATE AND CLEAN JSON TABLE" $ run $ do it "MIGRATE AND CLEAN JSON TABLE" $ run $ do
void $ runMigrationSilent migrateJSON void $ runMigrationSilent migrateJSON
cleanJSON cleanJSON
testJSONInsertions testJSONInsertions
testJSONOperators testJSONOperators
testLateralQuery testLateralQuery
run, runSilent, runVerbose :: Run run, runSilent, runVerbose :: Run
runSilent act = runNoLoggingT $ run_worker act runSilent act = runNoLoggingT $ run_worker act

View File

@ -4,7 +4,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Main (main) where module SQLite.Test where
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.IO.Class (MonadIO(liftIO))
@ -19,9 +19,6 @@ import Test.Hspec
import Common.Test import Common.Test
testSqliteRandom :: Spec testSqliteRandom :: Spec
testSqliteRandom = do testSqliteRandom = do
it "works with random_" $ it "works with random_" $
@ -162,7 +159,10 @@ testSqliteTextFunctions = do
main :: IO () main :: IO ()
main = do main = do
hspec $ do hspec spec
spec :: Spec
spec = do
tests run tests run
describe "Test SQLite locking" $ do describe "Test SQLite locking" $ do

22
test/Spec.hs Normal file
View File

@ -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