haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Pass ConnectionPool to tests (#262)

Browse Source 
* 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
This commit is contained in:
Matt Parsons 2021-05-28 15:34:56 -06:00 committed by GitHub
parent e145be999a
commit 34047e1f5f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 1532 additions and 1635 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -6,4 +6,5 @@ stack.yaml.lock
.cabal-sandbox/ .cabal-sandbox/
cabal.sandbox.config cabal.sandbox.config
.hspec-failures .hspec-failures
*.sqlite*
cabal.project.freeze cabal.project.freeze

14
Makefile
View File

@ -21,7 +21,19 @@ test-ghci:
stack ghci esqueleto:test:sqlite stack ghci esqueleto:test:sqlite
test-ghcid: 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: init-pgsql:
sudo -u postgres -- createuser -s esqutest sudo -u postgres -- createuser -s esqutest

6
esqueleto.cabal
View File

@ -77,7 +77,6 @@ library
-Widentities -Widentities
-Wcpp-undef -Wcpp-undef
-Wcpp-undef -Wcpp-undef
-Wmonomorphism-restriction
default-language: Haskell2010 default-language: Haskell2010
test-suite specs test-suite specs
@ -100,7 +99,6 @@ test-suite specs
build-depends: build-depends:
base >=4.8 && <5.0 base >=4.8 && <5.0
, aeson , aeson
, postgresql-simple
, attoparsec , attoparsec
, blaze-html , blaze-html
, bytestring , bytestring
@ -116,8 +114,10 @@ test-suite specs
, mysql-simple , mysql-simple
, persistent , persistent
, persistent-mysql , persistent-mysql
, persistent-sqlite
, persistent-postgresql , persistent-postgresql
, persistent-sqlite
, postgresql-simple
, QuickCheck
, resourcet , resourcet
, tagged , tagged
, text , text

1595
test/Common/Test.hs
View File

File diff suppressed because it is too large Load Diff

70
test/Common/Test/Import.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
@ -25,23 +25,63 @@ module Common.Test.Import
, module X , module X
) where ) where
import Control.Monad.Fail import System.Environment
import Control.Applicative
import Common.Test.Models as X import Common.Test.Models as X
import Control.Monad.Catch (MonadCatch) import Database.Esqueleto.Experimental as X hiding (random_)
import Control.Monad.Logger (MonadLogger(..), MonadLoggerIO(..))
import Database.Esqueleto.Experimental as X
import Test.Hspec as X import Test.Hspec as X
import UnliftIO 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 = type SpecDb = SpecWith ConnectionPool
( 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 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

32
test/Common/Test/Select.hs
View File

@ -2,25 +2,21 @@ module Common.Test.Select where
import Common.Test.Import import Common.Test.Import
testSelect :: Run -> Spec testSelect :: SpecDb
testSelect run = do testSelect = do
describe "select" $ do describe "select" $ do
it "works for a single value" $ itDb "works for a single value" $ do
run $ do ret <- select $ return $ val (3 :: Int)
ret <- select $ return $ val (3 :: Int) asserting $ ret `shouldBe` [ Value 3 ]
liftIO $ ret `shouldBe` [ Value 3 ]
it "works for a pair of a single value and ()" $ itDb "works for a pair of a single value and ()" $ do
run $ do ret <- select $ return (val (3 :: Int), ())
ret <- select $ return (val (3 :: Int), ()) asserting $ ret `shouldBe` [ (Value 3, ()) ]
liftIO $ ret `shouldBe` [ (Value 3, ()) ]
it "works for a single ()" $ itDb "works for a single ()" $ do
run $ do ret <- select $ return ()
ret <- select $ return () asserting $ ret `shouldBe` [ () ]
liftIO $ ret `shouldBe` [ () ]
it "works for a single NULL value" $ itDb "works for a single NULL value" $ do
run $ do ret <- select $ return nothing
ret <- select $ return nothing asserting $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]
liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]

123
test/MySQL/Test.hs
View File

@ -6,11 +6,13 @@
module MySQL.Test where module MySQL.Test where
import Common.Test.Import hiding (from, on)
import Control.Applicative import Control.Applicative
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) 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 qualified Control.Monad.Trans.Resource as R
import Database.Esqueleto import Database.Esqueleto
import Database.Esqueleto.Experimental hiding (from, on) import Database.Esqueleto.Experimental hiding (from, on)
@ -23,30 +25,16 @@ import Database.Persist.MySQL
, connectUser , connectUser
, defaultConnectInfo , defaultConnectInfo
, withMySQLConn , withMySQLConn
, createMySQLPool
) )
import System.Environment
import Test.Hspec import Test.Hspec
import Common.Test import Common.Test
testMysqlSum :: SpecDb
-- 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 = do testMysqlSum = do
it "works with sum_" $ itDb "works with sum_" $ do
run $ do
_ <- insert' p1 _ <- insert' p1
_ <- insert' p2 _ <- insert' p2
_ <- insert' p3 _ <- insert' p3
@ -56,13 +44,9 @@ testMysqlSum = do
return $ joinV $ sum_ (p ^. PersonAge) return $ joinV $ sum_ (p ^. PersonAge)
liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ] liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ]
testMysqlTwoAscFields :: SpecDb
testMysqlTwoAscFields :: Spec
testMysqlTwoAscFields = do testMysqlTwoAscFields = do
it "works with two ASC fields (one call)" $ itDb "works with two ASC fields (one call)" $ do
run $ do
p1e <- insert' p1 p1e <- insert' p1
p2e <- insert' p2 p2e <- insert' p2
p3e <- insert' p3 p3e <- insert' p3
@ -73,13 +57,9 @@ testMysqlTwoAscFields = do
return p return p
liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
testMysqlOneAscOneDesc :: SpecDb
testMysqlOneAscOneDesc :: Spec
testMysqlOneAscOneDesc = do testMysqlOneAscOneDesc = do
it "works with one ASC and one DESC field (two calls)" $ itDb "works with one ASC and one DESC field (two calls)" $ do
run $ do
p1e <- insert' p1 p1e <- insert' p1
p2e <- insert' p2 p2e <- insert' p2
p3e <- insert' p3 p3e <- insert' p3
@ -94,10 +74,9 @@ testMysqlOneAscOneDesc = do
testMysqlCoalesce :: Spec testMysqlCoalesce :: SpecDb
testMysqlCoalesce = do testMysqlCoalesce = do
it "works on PostgreSQL and MySQL with <2 arguments" $ itDb "works on PostgreSQL and MySQL with <2 arguments" $ do
run $ do
_ :: [Value (Maybe Int)] <- _ :: [Value (Maybe Int)] <-
select $ select $
from $ \p -> do from $ \p -> do
@ -107,10 +86,9 @@ testMysqlCoalesce = do
testMysqlUpdate :: Spec testMysqlUpdate :: SpecDb
testMysqlUpdate = do testMysqlUpdate = do
it "works on a simple example" $ itDb "works on a simple example" $ do
run $ do
p1k <- insert p1 p1k <- insert p1
p2k <- insert p2 p2k <- insert p2
p3k <- insert p3 p3k <- insert p3
@ -133,20 +111,13 @@ testMysqlUpdate = do
, Entity p1k (Person anon (Just 73) Nothing 1) , Entity p1k (Person anon (Just 73) Nothing 1)
, Entity p3k p3 ] , Entity p3k p3 ]
nameContains :: (SqlString s)
nameContains :: (BaseBackend backend ~ SqlBackend,
BackendCompatible SqlBackend backend,
MonadIO m, SqlString s,
IsPersistBackend backend, PersistQueryRead backend,
PersistUniqueRead backend)
=> (SqlExpr (Value [Char]) => (SqlExpr (Value [Char])
-> SqlExpr (Value s) -> SqlExpr (Value s)
-> SqlExpr (Value Bool)) -> SqlExpr (Value Bool))
-> s -> s
-> [Entity Person] -> [Entity Person]
-> ReaderT backend m () -> SqlPersistT IO ()
nameContains f t expected = do nameContains f t expected = do
ret <- select $ ret <- select $
from $ \p -> do from $ \p -> do
@ -158,22 +129,20 @@ nameContains f t expected = do
liftIO $ ret `shouldBe` expected liftIO $ ret `shouldBe` expected
testMysqlTextFunctions :: Spec testMysqlTextFunctions :: SpecDb
testMysqlTextFunctions = do testMysqlTextFunctions = do
describe "text functions" $ do describe "text functions" $ do
it "like, (%) and (++.) work on a simple example" $ itDb "like, (%) and (++.) work on a simple example" $ do
run $ do
[p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]
nameContains like "h" [p1e, p2e] nameContains like "h" [p1e, p2e]
nameContains like "i" [p4e, p3e] nameContains like "i" [p4e, p3e]
nameContains like "iv" [p4e] nameContains like "iv" [p4e]
testMysqlUnionWithLimits :: Spec testMysqlUnionWithLimits :: SpecDb
testMysqlUnionWithLimits = do testMysqlUnionWithLimits = do
describe "MySQL Union" $ do describe "MySQL Union" $ do
it "supports limit/orderBy by parenthesizing" $ do itDb "supports limit/orderBy by parenthesizing" $ do
run $ do
mapM_ (insert . Foo) [1..6] mapM_ (insert . Foo) [1..6]
let q1 = do let q1 = do
@ -195,11 +164,8 @@ testMysqlUnionWithLimits = do
liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5] liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5]
spec :: Spec spec :: Spec
spec = do spec = beforeAll mkConnectionPool $ do
tests run tests
describe "Test MySQL locking" $ do
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
@ -212,32 +178,17 @@ spec = do
testMysqlTextFunctions testMysqlTextFunctions
testMysqlUnionWithLimits 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 :: Bool
verbose = False verbose = False
migrateIt :: R.MonadUnliftIO m => SqlPersistT m ()
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 = do migrateIt = do
void $ runMigrationSilent migrateAll mapReaderT R.runResourceT $ void $ runMigrationSilent migrateAll
cleanDB cleanDB
mkConnectionPool :: IO ConnectionPool
withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a mkConnectionPool = do
withConn f = do ci <- isCI
ci <- liftIO isCI
let connInfo let connInfo
| ci = | ci =
defaultConnectInfo defaultConnectInfo
@ -255,12 +206,18 @@ withConn f = do
, connectDatabase = "esqutest" , connectDatabase = "esqutest"
, connectPort = 3306 , 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

17
test/PostgreSQL/MigrateJSON.hs
View File

@ -16,15 +16,12 @@
module PostgreSQL.MigrateJSON where module PostgreSQL.MigrateJSON where
import Control.Monad.Trans.Resource (ResourceT) import Common.Test.Import hiding (Value, from, on)
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 (RunDbMonad) import Data.Aeson (Value)
import Database.Esqueleto.Legacy (from)
import Database.Esqueleto.PostgreSQL.JSON (JSONB)
import Database.Persist.TH
-- JSON Table for PostgreSQL -- JSON Table for PostgreSQL
share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase| share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase|
@ -34,6 +31,6 @@ Json
|] |]
cleanJSON cleanJSON
:: (forall m. RunDbMonad m :: forall m. MonadIO m
=> SqlPersistT (ResourceT m) ()) => SqlPersistT m ()
cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return () cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return ()

1040
test/PostgreSQL/Test.hs
View File

File diff suppressed because it is too large Load Diff

269
test/SQLite/Test.hs
View File

@ -6,171 +6,135 @@
module SQLite.Test where module SQLite.Test where
import Common.Test.Import hiding (from, on)
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
import Control.Monad.Trans.Reader (ReaderT) import Database.Esqueleto.Legacy hiding (random_)
import qualified Control.Monad.Trans.Resource as R
import Database.Esqueleto hiding (random_)
import Database.Esqueleto.SQLite (random_) import Database.Esqueleto.SQLite (random_)
import Database.Persist.Sqlite (withSqliteConn) import Database.Persist.Sqlite (createSqlitePool)
import Database.Sqlite (SqliteException) import Database.Sqlite (SqliteException)
import Test.Hspec
import Common.Test import Common.Test
testSqliteRandom :: Spec testSqliteRandom :: SpecDb
testSqliteRandom = do testSqliteRandom = do
it "works with random_" $ itDb "works with random_" $ do
run $ do _ <- select $ return (random_ :: SqlExpr (Value Int))
_ <- select $ return (random_ :: SqlExpr (Value Int)) asserting noExceptions
return ()
testSqliteSum :: SpecDb
testSqliteSum :: Spec
testSqliteSum = do testSqliteSum = do
it "works with sum_" $ itDb "works with sum_" $ do
run $ do _ <- insert' p1
_ <- insert' p1 _ <- insert' p2
_ <- insert' p2 _ <- insert' p3
_ <- insert' p3 _ <- insert' p4
_ <- insert' p4 ret <- select $
ret <- select $ from $ \p->
from $ \p-> return $ joinV $ sum_ (p ^. PersonAge)
return $ joinV $ sum_ (p ^. PersonAge) asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ]
liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ]
testSqliteTwoAscFields :: Spec testSqliteTwoAscFields :: SpecDb
testSqliteTwoAscFields = do testSqliteTwoAscFields = do
it "works with two ASC fields (one call)" $ itDb "works with two ASC fields (one call)" $ do
run $ do p1e <- insert' p1
p1e <- insert' p1 p2e <- insert' p2
p2e <- insert' p2 p3e <- insert' p3
p3e <- insert' p3 p4e <- insert' p4
p4e <- insert' p4 ret <- select $
ret <- select $ from $ \p -> do
from $ \p -> do orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]
orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p
return p -- in SQLite and MySQL, its the reverse
-- in SQLite and MySQL, its the reverse asserting $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
testSqliteOneAscOneDesc :: SpecDb
testSqliteOneAscOneDesc :: Spec
testSqliteOneAscOneDesc = do testSqliteOneAscOneDesc = do
it "works with one ASC and one DESC field (two calls)" $ itDb "works with one ASC and one DESC field (two calls)" $ do
run $ do p1e <- insert' p1
p1e <- insert' p1 p2e <- insert' p2
p2e <- insert' p2 p3e <- insert' p3
p3e <- insert' p3 p4e <- insert' p4
p4e <- insert' p4 ret <- select $
ret <- select $ from $ \p -> do
from $ \p -> do orderBy [desc (p ^. PersonAge)]
orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)]
orderBy [asc (p ^. PersonName)] return p
return p asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]
liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]
testSqliteCoalesce :: SpecDb
testSqliteCoalesce :: Spec
testSqliteCoalesce = do testSqliteCoalesce = do
it "throws an exception on SQLite with <2 arguments" $ itDb "throws an exception on SQLite with <2 arguments" $ do
run (select $ eres <- try $ select $
from $ \p -> do from $ \p -> do
return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int)))) return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int)))
`shouldThrow` (\(_ :: SqliteException) -> True) asserting $ case eres of
Left (_ :: SqliteException) ->
pure ()
Right _ ->
expectationFailure "Expected SqliteException with <2 args to coalesce"
testSqliteUpdate :: SpecDb
testSqliteUpdate :: Spec
testSqliteUpdate = do testSqliteUpdate = do
it "works on a simple example" $ itDb "works on a simple example" $ do
run $ do p1k <- insert p1
p1k <- insert p1 p2k <- insert p2
p2k <- insert p2 p3k <- insert p3
p3k <- insert p3 let anon = "Anonymous" :: String
let anon = "Anonymous" () <- update $ \p -> do
() <- update $ \p -> do set p [ PersonName =. val anon
set p [ PersonName =. val anon , PersonAge *=. just (val 2) ]
, PersonAge *=. just (val 2) ] where_ (p ^. PersonName !=. val "Mike")
where_ (p ^. PersonName !=. val "Mike") n <- updateCount $ \p -> do
n <- updateCount $ \p -> do set p [ PersonAge +=. just (val 1) ]
set p [ PersonAge +=. just (val 1) ] where_ (p ^. PersonName !=. val "Mike")
where_ (p ^. PersonName !=. val "Mike") ret <- select $
ret <- select $ from $ \p -> do
from $ \p -> do orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]
orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p
return p -- SQLite: nulls appear first, update returns matched rows.
-- SQLite: nulls appear first, update returns matched rows. asserting $ do
liftIO $ n `shouldBe` 2 n `shouldBe` 2
liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2) ret `shouldMatchList`
, Entity p1k (Person anon (Just 73) Nothing 1) [ Entity p2k (Person anon Nothing (Just 37) 2)
, Entity p3k p3 ] , Entity p1k (Person anon (Just 73) Nothing 1)
, Entity p3k p3
]
testSqliteTextFunctions :: SpecDb
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 = do testSqliteTextFunctions = do
describe "text functions" $ do describe "text functions" $ do
it "like, (%) and (++.) work on a simple example" $ itDb "like, (%) and (++.) work on a simple example" $ do
run $ do let query :: String -> SqlPersistT IO [Entity Person]
[p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] query t =
nameContains like "h" [p1e, p2e] select $
nameContains like "i" [p4e, p3e] from $ \p -> do
nameContains like "iv" [p4e] 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 () spec :: HasCallStack => Spec
main = do spec = beforeAll mkConnectionPool $ do
hspec spec tests
spec :: Spec
spec = do
tests run
describe "Test SQLite locking" $ do
testLocking withConn
describe "SQLite specific tests" $ do describe "SQLite specific tests" $ do
testAscRandom random_ run testAscRandom random_
testRandomMath run testRandomMath
testSqliteRandom testSqliteRandom
testSqliteSum testSqliteSum
testSqliteTwoAscFields testSqliteTwoAscFields
@ -179,24 +143,23 @@ spec = do
testSqliteUpdate testSqliteUpdate
testSqliteTextFunctions testSqliteTextFunctions
run, runSilent, runVerbose :: Run mkConnectionPool :: IO ConnectionPool
runSilent act = runNoLoggingT $ run_worker act mkConnectionPool = do
runVerbose act = runStderrLoggingT $ run_worker act conn <-
run = if verbose
if verbose then runStderrLoggingT $
then runVerbose createSqlitePool ".esqueleto-test.sqlite" 4
else runSilent else runNoLoggingT $
createSqlitePool ".esqueleto-test.sqlite" 4
flip runSqlPool conn $ do
migrateIt
pure conn
verbose :: Bool verbose :: Bool
verbose = False verbose = False
run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a migrateIt :: MonadUnliftIO m => SqlPersistT m ()
run_worker act = withConn $ runSqlConn (migrateIt >> act)
migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()
migrateIt = do migrateIt = do
void $ runMigrationSilent migrateAll void $ runMigrationSilent migrateAll
cleanDB
withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a
withConn =
R.runResourceT . withSqliteConn ":memory:"