dbmigrations-1.1: test/TestDriver.hs

module Main where
import Prelude hiding ( catch )
import Test.HUnit
import System.Exit
import System.Process ( system )
import System.IO ( stderr )

import qualified BackendTest
import qualified DependencyTest
import qualified MigrationsTest
import qualified FilesystemSerializeTest
import qualified FilesystemParseTest
import qualified FilesystemTest
import qualified CycleDetectionTest
import qualified StoreTest
import qualified LinearMigrationsTest
import qualified ConfigurationTest

import Control.Monad ( forM )
import Control.Exception ( finally, catch, try, SomeException(..) )
import Data.String (fromString)

import Database.HDBC ( IConnection(disconnect) )
import Database.HDBC.Sqlite3 ( connectSqlite3 )
import qualified Database.HDBC.PostgreSQL as PostgreSQL
import qualified Database.MySQL.Simple as MySQL

loadTests :: IO [Test]
loadTests = do

  sqliteConn <- connectSqlite3 ":memory:"
  --pgConn <- setupPostgresDb
  mysqlConn <- setupMySQLDb

  let backends = [ ("Sqlite", (BackendTest.tests (BackendTest.HDBCConnection sqliteConn)) `finally`
                                (disconnect sqliteConn))
                 -- , ("PostgreSQL", (BackendTest.tests (BackendTest.HDBCConnection pgConn)) `finally`
                 --                    (disconnect pgConn >> teardownPostgresDb))
                 , ("MySQL", (BackendTest.tests (BackendTest.MySQLConnection mysqlConn)) `finally`
                               (MySQL.close mysqlConn >> teardownMySQLDb))
                 ]

  backendTests <- forM backends $ \(name, testAct) -> do
                    return $ (name ++ " backend tests") ~: test testAct

  ioTests <- sequence [ do fspTests <- FilesystemParseTest.tests
                           return $ "Filesystem Parsing" ~: test fspTests
                      , do fsTests <- FilesystemTest.tests
                           return $ "Filesystem general" ~: test fsTests
                      , do linTests <- LinearMigrationsTest.tests
                           return $ "Linear migrations" ~: test linTests
                      , do cfgTests <- ConfigurationTest.tests
                           return $ "Configuration tests" ~: test cfgTests
                      ]
  return $ concat [ backendTests
                  , ioTests
                  , DependencyTest.tests
                  , FilesystemSerializeTest.tests
                  , MigrationsTest.tests
                  , CycleDetectionTest.tests
                  , StoreTest.tests
                  ]

tempDatabase :: String
tempDatabase = "dbmigrations_test"

ignoreException :: SomeException -> IO ()
ignoreException _ = return ()

setupPostgresDb :: IO PostgreSQL.Connection
setupPostgresDb = do
  teardownPostgresDb `catch` ignoreException

  -- create database
  status <- system $ "createdb " ++ tempDatabase
  case status of
    ExitSuccess -> return ()
    ExitFailure _ -> error $ "Failed to create PostgreSQL database " ++ (show tempDatabase)

  -- return test db connection
  PostgreSQL.connectPostgreSQL $ "dbname=" ++ tempDatabase

teardownPostgresDb :: IO ()
teardownPostgresDb = do
  -- drop database
  status <- system $ "dropdb " ++ tempDatabase ++ " 2>/dev/null"
  case status of
    ExitSuccess -> return ()
    ExitFailure _ -> error $ "Failed to drop PostgreSQL database " ++ (show tempDatabase)

setupMySQLDb :: IO MySQL.Connection
setupMySQLDb = do
  teardownMySQLDb `catch` ignoreException
  conn <- MySQL.connect MySQL.defaultConnectInfo
  MySQL.execute_ conn (fromString ("CREATE DATABASE " ++ tempDatabase))
  MySQL.execute_ conn (fromString ("USE " ++ tempDatabase))
  pure conn

teardownMySQLDb :: IO ()
teardownMySQLDb = do
  conn <- MySQL.connect MySQL.defaultConnectInfo
  e <- try (MySQL.execute_ conn (fromString ("DROP DATABASE " ++ tempDatabase)))
  case e of
    Left ex@SomeException{} -> error ("Failed to drop test MySQL database: " ++ show ex)
    Right _ -> return ()

main :: IO ()
main = do
  tests <- loadTests
  (testResults, _) <- runTestText (putTextToHandle stderr False) $ test tests
  if errors testResults + failures testResults > 0
    then exitFailure
    else exitSuccess