{-# LANGUAGE OverloadedStrings #-}
module Database.Schema.Migrations.Test.BackendTest
( BackendConnection (..)
, tests
) where
import Data.ByteString ( ByteString )
import Control.Monad ( forM_ )
import Test.HUnit
import Database.Schema.Migrations.Migration ( Migration(..), newMigration )
import Database.Schema.Migrations.Backend ( Backend(..) )
class BackendConnection c where
supportsTransactionalDDL :: c -> Bool
commit :: c -> IO ()
withTransaction :: c -> (c -> IO a) -> IO a
getTables :: c -> IO [ByteString]
catchAll :: c -> (IO a -> IO a -> IO a)
makeBackend :: c -> Backend
testSuite :: BackendConnection bc => Bool -> [bc -> IO ()]
testSuite :: Bool -> [bc -> IO ()]
testSuite Bool
transactDDL =
[ bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
isBootstrappedFalseTest
, bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
bootstrapTest
, bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
isBootstrappedTrueTest
, if Bool
transactDDL then bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
applyMigrationFailure else (IO () -> bc -> IO ()
forall a b. a -> b -> a
const (IO () -> bc -> IO ()) -> IO () -> bc -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
applyMigrationSuccess
, bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
revertMigrationFailure
, bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
revertMigrationNothing
, bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
revertMigrationJust
]
tests :: BackendConnection bc => bc -> IO ()
tests :: bc -> IO ()
tests bc
conn = do
let acts :: [bc -> IO ()]
acts = Bool -> [bc -> IO ()]
forall bc. BackendConnection bc => Bool -> [bc -> IO ()]
testSuite (Bool -> [bc -> IO ()]) -> Bool -> [bc -> IO ()]
forall a b. (a -> b) -> a -> b
$ bc -> Bool
forall c. BackendConnection c => c -> Bool
supportsTransactionalDDL bc
conn
[bc -> IO ()] -> ((bc -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [bc -> IO ()]
acts (((bc -> IO ()) -> IO ()) -> IO ())
-> ((bc -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \bc -> IO ()
act -> do
bc -> IO ()
forall bc. BackendConnection bc => bc -> IO ()
commit bc
conn
bc -> IO ()
act bc
conn
bootstrapTest :: BackendConnection bc => bc -> IO ()
bootstrapTest :: bc -> IO ()
bootstrapTest bc
conn = do
let backend :: Backend
backend = bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn
Migration
bs <- Backend -> IO Migration
getBootstrapMigration Backend
backend
Backend -> Migration -> IO ()
applyMigration Backend
backend Migration
bs
String -> [ByteString] -> [ByteString] -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual String
"installed_migrations table exists" [ByteString
"installed_migrations"] ([ByteString] -> IO ()) -> IO [ByteString] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< bc -> IO [ByteString]
forall c. BackendConnection c => c -> IO [ByteString]
getTables bc
conn
String -> [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual String
"successfully bootstrapped" [Migration -> Text
mId Migration
bs] ([Text] -> IO ()) -> IO [Text] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Backend -> IO [Text]
getMigrations Backend
backend
isBootstrappedTrueTest :: BackendConnection bc => bc -> IO ()
isBootstrappedTrueTest :: bc -> IO ()
isBootstrappedTrueTest bc
conn = do
Bool
result <- Backend -> IO Bool
isBootstrapped (Backend -> IO Bool) -> Backend -> IO Bool
forall a b. (a -> b) -> a -> b
$ bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn
HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Bootstrapped check" Bool
result
isBootstrappedFalseTest :: BackendConnection bc => bc -> IO ()
isBootstrappedFalseTest :: bc -> IO ()
isBootstrappedFalseTest bc
conn = do
Bool
result <- Backend -> IO Bool
isBootstrapped (Backend -> IO Bool) -> Backend -> IO Bool
forall a b. (a -> b) -> a -> b
$ bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn
HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Bootstrapped check" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
result
ignoreSqlExceptions :: BackendConnection bc => bc -> IO a -> IO (Maybe a)
ignoreSqlExceptions :: bc -> IO a -> IO (Maybe a)
ignoreSqlExceptions bc
conn IO a
act =
(bc -> IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)
forall c a. BackendConnection c => c -> IO a -> IO a -> IO a
catchAll bc
conn)
(IO a
act IO a -> (a -> IO (Maybe a)) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> (a -> Maybe a) -> a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
(Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)
applyMigrationSuccess :: BackendConnection bc => bc -> IO ()
applyMigrationSuccess :: bc -> IO ()
applyMigrationSuccess bc
conn = do
let backend :: Backend
backend = bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn
let m1 :: Migration
m1 = (Text -> Migration
newMigration Text
"validMigration") { mApply :: Text
mApply = Text
"CREATE TABLE valid1 (a int)" }
bc -> (bc -> IO ()) -> IO ()
forall c a. BackendConnection c => c -> (c -> IO a) -> IO a
withTransaction bc
conn ((bc -> IO ()) -> IO ()) -> (bc -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \bc
conn' -> Backend -> Migration -> IO ()
applyMigration (bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn') Migration
m1
String -> [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual String
"Installed migrations" [Text
"root", Text
"validMigration"] ([Text] -> IO ()) -> IO [Text] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Backend -> IO [Text]
getMigrations Backend
backend
String -> [ByteString] -> [ByteString] -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual String
"Installed tables" [ByteString
"installed_migrations", ByteString
"valid1"] ([ByteString] -> IO ()) -> IO [ByteString] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< bc -> IO [ByteString]
forall c. BackendConnection c => c -> IO [ByteString]
getTables bc
conn
applyMigrationFailure :: BackendConnection bc => bc -> IO ()
applyMigrationFailure :: bc -> IO ()
applyMigrationFailure bc
conn = do
let backend :: Backend
backend = bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn
let m1 :: Migration
m1 = (Text -> Migration
newMigration Text
"second") { mApply :: Text
mApply = Text
"CREATE TABLE validButTemporary (a int)" }
m2 :: Migration
m2 = (Text -> Migration
newMigration Text
"third") { mApply :: Text
mApply = Text
"INVALID SQL" }
Maybe ()
_ <- bc -> IO () -> IO (Maybe ())
forall bc a. BackendConnection bc => bc -> IO a -> IO (Maybe a)
ignoreSqlExceptions bc
conn (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ bc -> (bc -> IO ()) -> IO ()
forall c a. BackendConnection c => c -> (c -> IO a) -> IO a
withTransaction bc
conn ((bc -> IO ()) -> IO ()) -> (bc -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \bc
conn' -> do
let backend' :: Backend
backend' = bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn'
Backend -> Migration -> IO ()
applyMigration Backend
backend' Migration
m1
Backend -> Migration -> IO ()
applyMigration Backend
backend' Migration
m2
String -> [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual String
"Installed migrations" [Text
"root"] ([Text] -> IO ()) -> IO [Text] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Backend -> IO [Text]
getMigrations Backend
backend
String -> [ByteString] -> [ByteString] -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual String
"Installed tables" [ByteString
"installed_migrations"] ([ByteString] -> IO ()) -> IO [ByteString] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< bc -> IO [ByteString]
forall c. BackendConnection c => c -> IO [ByteString]
getTables bc
conn
revertMigrationFailure :: BackendConnection bc => bc -> IO ()
revertMigrationFailure :: bc -> IO ()
revertMigrationFailure bc
conn = do
let backend :: Backend
backend = bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn
let m1 :: Migration
m1 = (Text -> Migration
newMigration Text
"second") { mApply :: Text
mApply = Text
"CREATE TABLE validRMF (a int)"
, mRevert :: Maybe Text
mRevert = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"DROP TABLE validRMF"}
m2 :: Migration
m2 = (Text -> Migration
newMigration Text
"third") { mApply :: Text
mApply = Text
"alter table validRMF add column b int"
, mRevert :: Maybe Text
mRevert = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"INVALID REVERT SQL"}
Backend -> Migration -> IO ()
applyMigration Backend
backend Migration
m1
Backend -> Migration -> IO ()
applyMigration Backend
backend Migration
m2
[Text]
installedBeforeRevert <- Backend -> IO [Text]
getMigrations Backend
backend
Backend -> IO ()
commitBackend Backend
backend
Maybe ()
_ <- bc -> IO () -> IO (Maybe ())
forall bc a. BackendConnection bc => bc -> IO a -> IO (Maybe a)
ignoreSqlExceptions bc
conn (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ bc -> (bc -> IO ()) -> IO ()
forall c a. BackendConnection c => c -> (c -> IO a) -> IO a
withTransaction bc
conn ((bc -> IO ()) -> IO ()) -> (bc -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \bc
conn' -> do
let backend' :: Backend
backend' = bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn'
Backend -> Migration -> IO ()
revertMigration Backend
backend' Migration
m2
Backend -> Migration -> IO ()
revertMigration Backend
backend' Migration
m1
String -> [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual String
"successfully roll back failed revert" [Text]
installedBeforeRevert
([Text] -> IO ()) -> IO [Text] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Backend -> IO [Text]
getMigrations Backend
backend
revertMigrationNothing :: BackendConnection bc => bc -> IO ()
revertMigrationNothing :: bc -> IO ()
revertMigrationNothing bc
conn = do
let backend :: Backend
backend = bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn
let m1 :: Migration
m1 = (Text -> Migration
newMigration Text
"second") { mApply :: Text
mApply = Text
"create table revert_nothing (a int)"
, mRevert :: Maybe Text
mRevert = Maybe Text
forall a. Maybe a
Nothing }
Backend -> Migration -> IO ()
applyMigration Backend
backend Migration
m1
[Text]
installedAfterApply <- Backend -> IO [Text]
getMigrations Backend
backend
HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Check that the migration was applied" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"second" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
installedAfterApply
Backend -> Migration -> IO ()
revertMigration Backend
backend Migration
m1
[Text]
installed <- Backend -> IO [Text]
getMigrations Backend
backend
HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Check that the migration was reverted" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"second" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
installed
revertMigrationJust :: BackendConnection bc => bc -> IO ()
revertMigrationJust :: bc -> IO ()
revertMigrationJust bc
conn = do
let name :: Text
name = Text
"revertable"
backend :: Backend
backend = bc -> Backend
forall c. BackendConnection c => c -> Backend
makeBackend bc
conn
let m1 :: Migration
m1 = (Text -> Migration
newMigration Text
name) { mApply :: Text
mApply = Text
"CREATE TABLE the_test_table (a int)"
, mRevert :: Maybe Text
mRevert = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"DROP TABLE the_test_table" }
Backend -> Migration -> IO ()
applyMigration Backend
backend Migration
m1
[Text]
installedAfterApply <- Backend -> IO [Text]
getMigrations Backend
backend
HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Check that the migration was applied" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
installedAfterApply
Backend -> Migration -> IO ()
revertMigration Backend
backend Migration
m1
[Text]
installed <- Backend -> IO [Text]
getMigrations Backend
backend
HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Check that the migration was reverted" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
installed