{-# LANGUAGE OverloadedStrings #-}

-- | A test that is not executed as part of this package's test suite but rather
-- acts as a conformance test suit for database specific backend
-- implementations. All backend specific executable packages are expected to
-- have a test suite that runs this test.
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(..) )

-- | A typeclass for database connections that needs to implemented for each
-- specific database type to use this test.
class BackendConnection c where

    -- | Whether this backend supports transactional DDL; if it doesn't,
    -- we'll skip any tests that rely on that behavior.
    supportsTransactionalDDL :: c -> Bool

    -- | Commits the current transaction.
    commit :: c -> IO ()

    -- | Executes an IO action inside a transaction.
    withTransaction :: c -> (c -> IO a) -> IO a

    -- | Retrieves a list of all tables in the current database/scheme.
    getTables :: c -> IO [ByteString]

    catchAll :: c -> (IO a -> IO a -> IO a)

    -- | Returns a backend instance.
    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)" }

    -- Apply the migrations, ignore exceptions
    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

    -- Check that none of the migrations were installed
    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

-- |Does a failure to apply a migration imply a transaction rollback?
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" }

    -- Apply the migrations, ignore exceptions
    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

    -- Check that none of the migrations were installed
    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

    -- Revert the migrations, ignore exceptions; the revert will fail,
    -- but withTransaction will roll back.
    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

    -- Check that none of the migrations were reverted
    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

    -- Revert the migration, which should do nothing EXCEPT remove it
    -- from the installed list
    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

    -- Revert the migration, which should do nothing EXCEPT remove it
    -- from the installed list
    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