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
This commit is contained in:
Matt Parsons
GitHub
parent
e145be999a
commit
34047e1f5f
1
.gitignore
vendored
1
.gitignore
vendored
@ -6,4 +6,5 @@ stack.yaml.lock
|
||||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
.hspec-failures
|
||||
*.sqlite*
|
||||
cabal.project.freeze
|
||||
|
||||
14
Makefile
14
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
|
||||
|
||||
@ -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
|
||||
|
||||
1595
test/Common/Test.hs
1595
test/Common/Test.hs
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
@ -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) ]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ()
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user