diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 0.8.1 +Version: 0.8.2 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -25,8 +25,26 @@ License: BSD3 License-File: LICENSE Cabal-Version: >= 1.10 -Data-Files: README.md MOO.TXT +Data-Files: + README.md + MOO.TXT + test/example_store/root + test/example_store/update1 + test/example_store/update2 + test/migration_parsing/invalid_field_name.txt + test/migration_parsing/invalid_missing_required_fields.txt + test/migration_parsing/invalid_syntax.txt + test/migration_parsing/invalid_timestamp.txt + test/migration_parsing/valid_full.txt + test/migration_parsing/valid_no_depends.txt + test/migration_parsing/valid_no_desc.txt + test/migration_parsing/valid_no_revert.txt + test/migration_parsing/valid_with_colon.txt + test/migration_parsing/valid_with_comments.txt + test/migration_parsing/valid_with_comments2.txt + test/migration_parsing/valid_with_multiline_deps.txt + Source-Repository head type: git location: git://github.com/jtdaugherty/dbmigrations.git @@ -42,18 +60,18 @@ Build-Depends: base >= 4 && < 5, HDBC >= 2.2.1, - time >= 1.4 && < 1.6, - random >= 1.0 && < 1.2, - containers >= 0.2 && < 0.6, - mtl >= 2.1 && < 3, - filepath >= 1.1 && < 1.4, - directory >= 1.0 && < 1.3, - fgl >= 5.4 && < 5.6, + time >= 1.4, + random >= 1.0, + containers >= 0.2, + mtl >= 2.1, + filepath >= 1.1, + directory >= 1.0, + fgl >= 5.4, template-haskell, - yaml-light >= 0.1 && < 0.2, - bytestring >= 0.9 && < 1.0, - text >= 0.11 && < 1.3, - configurator >= 0.2 && < 0.4, + yaml-light >= 0.1, + bytestring >= 0.9, + text >= 0.11, + configurator >= 0.2, HDBC-postgresql, HDBC-sqlite3 @@ -66,6 +84,7 @@ Database.Schema.Migrations.Backend Database.Schema.Migrations.Backend.HDBC Database.Schema.Migrations.Store + Moo.Main Other-Modules: Database.Schema.Migrations.CycleDetection @@ -80,21 +99,34 @@ type: exitcode-stdio-1.0 Build-Depends: base >= 4 && < 5, - time >= 1.4 && < 1.6, - containers >= 0.2 && < 0.6, - mtl >= 2.1 && < 3, - filepath >= 1.1 && < 1.4, - directory >= 1.0 && < 1.3, - fgl >= 5.4 && < 5.6, + time >= 1.4, + containers >= 0.2, + mtl >= 2.1, + filepath >= 1.1, + directory >= 1.0, + fgl >= 5.4, template-haskell, - yaml-light >= 0.1 && < 0.2, - bytestring >= 0.9 && < 1.0, + yaml-light >= 0.1, + bytestring >= 0.9, HDBC >= 2.2.1, HDBC-postgresql, HDBC-sqlite3, - HUnit >= 1.2 && < 1.3, + HUnit >= 1.2, process >= 1.1 + other-modules: + BackendTest + Common + CommonTH + CycleDetectionTest + DependencyTest + FilesystemParseTest + FilesystemSerializeTest + FilesystemTest + MigrationsTest + StoreTest + TestDriver + if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -Wwarn @@ -109,18 +141,18 @@ Build-Depends: base >= 4 && < 5, HDBC >= 2.2.1, - time >= 1.4 && < 1.6, - random >= 1.0 && < 1.2, - containers >= 0.2 && < 0.6, - mtl >= 2.1 && < 3, - filepath >= 1.1 && < 1.4, - directory >= 1.0 && < 1.3, - fgl >= 5.4 && < 5.6, + time >= 1.4, + random >= 1.0, + containers >= 0.2, + mtl >= 2.1, + filepath >= 1.1, + directory >= 1.0, + fgl >= 5.4, template-haskell, - yaml-light >= 0.1 && < 0.2, - bytestring >= 0.9 && < 1.0, - text >= 0.11 && < 1.3, - configurator >= 0.2 && < 0.4, + yaml-light >= 0.1, + bytestring >= 0.9, + text >= 0.11, + configurator >= 0.2, HDBC-postgresql, HDBC-sqlite3 diff --git a/src/Moo.hs b/src/Moo.hs --- a/src/Moo.hs +++ b/src/Moo.hs @@ -1,50 +1,15 @@ module Main - ( main ) + ( main + ) where import Control.Monad (liftM) -import Control.Monad.Reader (forM_, runReaderT, when) import Data.Configurator -import Data.List (intercalate) -import Data.Maybe (fromMaybe) -import Database.HDBC (SqlError, catchSql, seErrorMsg) import Prelude hiding (lookup) -import System.Environment (getArgs, getEnvironment, getProgName) -import System.Exit (ExitCode (ExitFailure), exitWith) - -import Database.Schema.Migrations.Filesystem (FilesystemStore (..)) -import Database.Schema.Migrations.Store -import Moo.CommandInterface -import Moo.Core - -reportSqlError :: SqlError -> IO a -reportSqlError e = do - putStrLn $ "\n" ++ "A database error occurred: " ++ seErrorMsg e - exitWith (ExitFailure 1) - -usage :: IO a -usage = do - progName <- getProgName - - putStrLn $ "Usage: " ++ progName ++ " [args]" - putStrLn "Environment:" - putStrLn $ " " ++ envDatabaseName ++ ": database connection string" - putStrLn $ " " ++ envDatabaseType ++ ": database type, one of " ++ - intercalate "," (map fst databaseTypes) - putStrLn $ " " ++ envStoreName ++ ": path to migration store" - putStrLn "Commands:" - forM_ commands $ \command -> do - putStrLn $ " " ++ usageString command - putStrLn $ " " ++ _cDescription command - putStrLn "" - - putStrLn commandOptionUsage - exitWith (ExitFailure 1) +import System.Environment (getArgs, getEnvironment) -usageSpecific :: Command -> IO a -usageSpecific command = do - putStrLn $ "Usage: initstore-fs " ++ usageString command - exitWith (ExitFailure 1) +import Moo.Core +import Moo.Main loadConfiguration :: Maybe FilePath -> IO Configuration loadConfiguration Nothing = liftM fromShellEnvironment getEnvironment @@ -52,44 +17,7 @@ main :: IO () main = do - allArgs <- getArgs - when (null allArgs) usage - let (commandName:unprocessedArgs) = allArgs - - command <- case findCommand commandName of - Nothing -> usage - Just c -> return c - - (opts, required) <- getCommandArgs unprocessedArgs - - let optionalConfigPath = _configFilePath opts - - conf <- loadConfiguration optionalConfigPath - let mDbConnStr = _connectionString conf - let mDbType = _databaseType conf - let mStoreName = _migrationStorePath conf - let storePathStr = - fromMaybe (error $ "Error: missing required environment variable " ++ envStoreName) - mStoreName - - let store = FSStore { storePath = storePathStr } - - if length required < length ( _cRequired command) then - usageSpecific command else - do - loadedStoreData <- loadMigrations store - case loadedStoreData of - Left es -> do - putStrLn "There were errors in the migration store:" - forM_ es $ \err -> putStrLn $ " " ++ show err - Right storeData -> do - let st = AppState { _appOptions = opts - , _appCommand = command - , _appRequiredArgs = required - , _appOptionalArgs = ["" :: String] - , _appDatabaseConnStr = liftM DbConnDescriptor mDbConnStr - , _appDatabaseType = mDbType - , _appStore = FSStore storePathStr - , _appStoreData = storeData - } - runReaderT (_cHandler command storeData) st `catchSql` reportSqlError + args <- getArgs + (_, opts, _) <- procArgs args + conf <- loadConfiguration $ _configFilePath opts + mainWithConf args conf diff --git a/src/Moo/Main.hs b/src/Moo/Main.hs new file mode 100644 --- /dev/null +++ b/src/Moo/Main.hs @@ -0,0 +1,99 @@ +module Moo.Main + ( mainWithConf + , Configuration (..) + , Args + , usage + , usageSpecific + , procArgs + ) +where + +import Control.Monad (liftM) +import Control.Monad.Reader (forM_, runReaderT, when) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Database.HDBC (SqlError, catchSql, seErrorMsg) +import Prelude hiding (lookup) +import System.Environment (getProgName) +import System.Exit (ExitCode (ExitFailure), exitWith) + +import Database.Schema.Migrations.Filesystem (FilesystemStore (..)) +import Database.Schema.Migrations.Store +import Moo.CommandInterface +import Moo.Core + +type Args = [String] + +usage :: IO a +usage = do + progName <- getProgName + + putStrLn $ "Usage: " ++ progName ++ " [args]" + putStrLn "Environment:" + putStrLn $ " " ++ envDatabaseName ++ ": database connection string" + putStrLn $ " " ++ envDatabaseType ++ ": database type, one of " ++ + intercalate "," (map fst databaseTypes) + putStrLn $ " " ++ envStoreName ++ ": path to migration store" + putStrLn "Commands:" + forM_ commands $ \command -> do + putStrLn $ " " ++ usageString command + putStrLn $ " " ++ _cDescription command + putStrLn "" + + putStrLn commandOptionUsage + exitWith (ExitFailure 1) + +usageSpecific :: Command -> IO a +usageSpecific command = do + putStrLn $ "Usage: initstore-fs " ++ usageString command + exitWith (ExitFailure 1) + +procArgs :: Args -> IO (Command, CommandOptions, [String]) +procArgs args = do + when (null args) usage + + command <- case findCommand $ head args of + Nothing -> usage + Just c -> return c + + (opts, required) <- getCommandArgs $ tail args + + return (command, opts, required) + +mainWithConf :: Args -> Configuration -> IO () +mainWithConf args conf = do + (command, opts, required) <- procArgs args + + let mDbConnStr = _connectionString conf + let mDbType = _databaseType conf + let mStoreName = _migrationStorePath conf + let storePathStr = + fromMaybe (error $ "Error: missing required environment variable " ++ envStoreName) + mStoreName + + let store = FSStore { storePath = storePathStr } + + if length required < length ( _cRequired command) then + usageSpecific command else + do + loadedStoreData <- loadMigrations store + case loadedStoreData of + Left es -> do + putStrLn "There were errors in the migration store:" + forM_ es $ \err -> putStrLn $ " " ++ show err + Right storeData -> do + let st = AppState { _appOptions = opts + , _appCommand = command + , _appRequiredArgs = required + , _appOptionalArgs = ["" :: String] + , _appDatabaseConnStr = liftM DbConnDescriptor mDbConnStr + , _appDatabaseType = mDbType + , _appStore = FSStore storePathStr + , _appStoreData = storeData + } + runReaderT (_cHandler command storeData) st `catchSql` reportSqlError + +reportSqlError :: SqlError -> IO a +reportSqlError e = do + putStrLn $ "\n" ++ "A database error occurred: " ++ seErrorMsg e + exitWith (ExitFailure 1) diff --git a/test/BackendTest.hs b/test/BackendTest.hs new file mode 100644 --- /dev/null +++ b/test/BackendTest.hs @@ -0,0 +1,143 @@ +module BackendTest where + +import Test.HUnit +import Control.Monad ( forM_ ) + +import Database.Schema.Migrations.Backend.HDBC () +import Database.Schema.Migrations.Migration ( Migration(..), newMigration ) +import Database.Schema.Migrations.Backend ( Backend(..) ) + +import Database.HDBC ( IConnection(..), catchSql, withTransaction ) + +tests :: (IConnection a) => a -> IO () +tests conn = do + let acts = [ isBootstrappedFalseTest + , bootstrapTest + , isBootstrappedTrueTest + , applyMigrationFailure + , applyMigrationSuccess + , revertMigrationFailure + , revertMigrationNothing + , revertMigrationJust + ] + forM_ acts $ \act -> do + commit conn + act conn + +bootstrapTest :: (IConnection a) => a -> IO () +bootstrapTest conn = do + bs <- getBootstrapMigration conn + applyMigration conn bs + assertEqual "installed_migrations table exists" ["installed_migrations"] =<< getTables conn + assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations conn + +isBootstrappedTrueTest :: (IConnection a) => a -> IO () +isBootstrappedTrueTest conn = do + result <- isBootstrapped conn + assertBool "Bootstrapped check" result + +isBootstrappedFalseTest :: (IConnection a) => a -> IO () +isBootstrappedFalseTest conn = do + result <- isBootstrapped conn + assertBool "Bootstrapped check" $ not result + +ignoreSqlExceptions :: IO a -> IO (Maybe a) +ignoreSqlExceptions act = (act >>= return . Just) `catchSql` + (\_ -> return Nothing) + +applyMigrationSuccess :: (IConnection a) => a -> IO () +applyMigrationSuccess conn = do + m1 <- newMigration "validMigration" + + let m1' = m1 { mApply = "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int);" } + + -- Apply the migrations, ignore exceptions + withTransaction conn $ \conn' -> applyMigration conn' m1' + + -- Check that none of the migrations were installed + assertEqual "Installed migrations" ["root", "validMigration"] =<< getMigrations conn + assertEqual "Installed tables" ["installed_migrations", "valid1", "valid2"] =<< getTables conn + +-- |Does a failure to apply a migration imply a transaction rollback? +applyMigrationFailure :: (IConnection a) => a -> IO () +applyMigrationFailure conn = do + m1 <- newMigration "second" + m2 <- newMigration "third" + + let m1' = m1 { mApply = "CREATE TABLE validButTemporary (a int)" } + let m2' = m2 { mApply = "INVALID SQL" } + + -- Apply the migrations, ignore exceptions + ignoreSqlExceptions $ withTransaction conn $ \conn' -> do + applyMigration conn' m1' + applyMigration conn' m2' + + -- Check that none of the migrations were installed + assertEqual "Installed migrations" ["root"] =<< getMigrations conn + assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn + +revertMigrationFailure :: (IConnection a) => a -> IO () +revertMigrationFailure conn = do + m1 <- newMigration "second" + m2 <- newMigration "third" + + let m1' = m1 { mApply = "CREATE TABLE validRMF (a int)" + , mRevert = Just "DROP TABLE validRMF"} + let m2' = m2 { mApply = "SELECT * FROM validRMF" + , mRevert = Just "INVALID REVERT SQL"} + + applyMigration conn m1' + applyMigration conn m2' + + installedBeforeRevert <- getMigrations conn + + commit conn + + -- Revert the migrations, ignore exceptions; the revert will fail, + -- but withTransaction will roll back. + ignoreSqlExceptions $ withTransaction conn $ \conn' -> do + revertMigration conn' m2' + revertMigration conn' m1' + + -- Check that none of the migrations were reverted + assertEqual "successfully roll back failed revert" installedBeforeRevert + =<< getMigrations conn + +revertMigrationNothing :: (IConnection a) => a -> IO () +revertMigrationNothing conn = do + m1 <- newMigration "second" + + let m1' = m1 { mApply = "SELECT 1" + , mRevert = Nothing } + + applyMigration conn m1' + + installedAfterApply <- getMigrations conn + assertBool "Check that the migration was applied" $ "second" `elem` installedAfterApply + + -- Revert the migration, which should do nothing EXCEPT remove it + -- from the installed list + revertMigration conn m1' + + installed <- getMigrations conn + assertBool "Check that the migration was reverted" $ not $ "second" `elem` installed + +revertMigrationJust :: (IConnection a) => a -> IO () +revertMigrationJust conn = do + let name = "revertable" + m1 <- newMigration name + + let m1' = m1 { mApply = "CREATE TABLE the_test_table (a int)" + , mRevert = Just "DROP TABLE the_test_table" } + + applyMigration conn m1' + + installedAfterApply <- getMigrations conn + assertBool "Check that the migration was applied" $ name `elem` installedAfterApply + + -- Revert the migration, which should do nothing EXCEPT remove it + -- from the installed list + revertMigration conn m1' + + installed <- getMigrations conn + assertBool "Check that the migration was reverted" $ not $ name `elem` installed diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} +module Common + ( TestDependable(..) + , repoRoot + , testFile + ) +where + +import CommonTH +import System.FilePath ( () ) +import Language.Haskell.TH.Syntax (lift) + +import Database.Schema.Migrations.Dependencies ( Dependable(..) ) + +repoRoot :: FilePath +repoRoot = $(getRepoRoot >>= lift) + +testFile :: FilePath -> FilePath +testFile fp = repoRoot "test" fp + +instance Dependable TestDependable where + depId = tdId + depsOf = tdDeps + +data TestDependable = TD { tdId :: String + , tdDeps :: [String] + } + deriving (Show, Eq, Ord) diff --git a/test/CommonTH.hs b/test/CommonTH.hs new file mode 100644 --- /dev/null +++ b/test/CommonTH.hs @@ -0,0 +1,16 @@ +module CommonTH + ( getRepoRoot + ) +where + +import Language.Haskell.TH +import System.FilePath ( takeDirectory, combine ) +import System.Directory ( getCurrentDirectory, canonicalizePath ) + +getRepoRoot :: Q FilePath +getRepoRoot = + do here <- location + cwd <- runIO getCurrentDirectory + let thisFileName = combine cwd $ loc_filename here + -- XXX: This depends on the location of this file in the source tree + return =<< runIO $ canonicalizePath $ head $ drop 2 $ iterate takeDirectory thisFileName diff --git a/test/CycleDetectionTest.hs b/test/CycleDetectionTest.hs new file mode 100644 --- /dev/null +++ b/test/CycleDetectionTest.hs @@ -0,0 +1,69 @@ +module CycleDetectionTest + ( tests + ) +where + +import Test.HUnit +import Data.Graph.Inductive.PatriciaTree ( Gr ) +import Data.Graph.Inductive.Graph ( mkGraph ) + +import Database.Schema.Migrations.CycleDetection + +tests :: [Test] +tests = mkCycleTests + +noCycles :: Gr String String +noCycles = mkGraph [(1,"one"),(2,"two")] [(1,2,"one->two")] + +noCyclesEmpty :: Gr String String +noCyclesEmpty = mkGraph [] [] + +withCycleSimple :: Gr String String +withCycleSimple = mkGraph [(1,"one")] [(1,1,"one->one")] + +withCycleComplex :: Gr String String +withCycleComplex = mkGraph [(1,"one"),(2,"two"),(3,"three"),(4,"four")] + [(4,1,"four->one"),(1,2,"one->two"),(2,3,"two->three"),(3,1,"three->one")] + +withCycleRadial :: Gr String String +withCycleRadial = mkGraph [(1,"one"),(2,"two"),(3,"three"),(4,"four")] + [(2,1,""),(2,3,""),(3,4,""),(3,2,"")] + +noCycleRadial :: Gr String String +noCycleRadial = mkGraph [(1,""),(2,""),(3,""),(4,"")] + [(1,2,""),(3,1,""),(4,1,"")] + +-- This graph would contain a loop if it were undirected, but it does +-- not contain a directed cycle. +noDirectedCycle1 :: Gr String String +noDirectedCycle1 = mkGraph [(1,""),(2,""),(3,""),(4,"")] + [(1,2,""),(1,3,""),(3,2,""),(2,4,"")] + +-- This graph would contain a loop if it were undirected, but it does +-- not contain a directed cycle. +noDirectedCycle2 :: Gr String String +noDirectedCycle2 = mkGraph [(1,"flub"),(2,"test.db"),(3,"test2"),(4,"test3"),(5,"test1")] + [ (1,2,"flub->test.db") + , (2,3,"test.db->test2") + , (2,4,"test.db->test3") + , (3,5,"test2->test1") + , (4,3,"test3->test2") + ] + +type CycleTestCase = (Gr String String, Bool) + +cycleTests :: [CycleTestCase] +cycleTests = [ (noCyclesEmpty, False) + , (noCycles, False) + , (noCycleRadial, False) + , (withCycleSimple, True) + , (withCycleComplex, True) + , (withCycleRadial, True) + , (noDirectedCycle1, False) + , (noDirectedCycle2, False) + ] + +mkCycleTests :: [Test] +mkCycleTests = map mkCycleTest cycleTests + where + mkCycleTest (g, expected) = expected ~=? hasCycle g diff --git a/test/DependencyTest.hs b/test/DependencyTest.hs new file mode 100644 --- /dev/null +++ b/test/DependencyTest.hs @@ -0,0 +1,79 @@ +module DependencyTest + ( tests + ) +where + +import Test.HUnit +import Data.Graph.Inductive.Graph ( Graph(..) ) + +import Database.Schema.Migrations.Dependencies +import Common + +tests :: [Test] +tests = depGraphTests ++ dependencyTests + +type DepGraphTestCase = ([TestDependable], Either String (DependencyGraph TestDependable)) + +depGraphTestCases :: [DepGraphTestCase] +depGraphTestCases = [ ( [] + , Right $ DG [] [] empty + ) + , ( [first, second] + , Right $ DG [(first,1),(second,2)] + [("first",1),("second",2)] (mkGraph [(1, "first"), (2, "second")] + [(2, 1, "first -> second")]) + ) + , ( [cycleFirst, cycleSecond] + , Left "Invalid dependency graph; cycle detected") + ] + where + first = TD "first" [] + second = TD "second" ["first"] + cycleFirst = TD "first" ["second"] + cycleSecond = TD "second" ["first"] + +depGraphTests :: [Test] +depGraphTests = map mkDepGraphTest depGraphTestCases + +mkDepGraphTest :: DepGraphTestCase -> Test +mkDepGraphTest (input, expected) = expected ~=? mkDepGraph input + +data Direction = Forward | Reverse deriving (Show) +type DependencyTestCase = ([TestDependable], String, Direction, [String]) + +dependencyTestCases :: [DependencyTestCase] +dependencyTestCases = [ ([TD "first" []], "first", Forward, []) + , ([TD "first" []], "first", Reverse, []) + + , ([TD "first" ["second"], TD "second" []], "first", Forward, ["second"]) + , ([TD "first" ["second"], TD "second" []], "second", Reverse, ["first"]) + , ([TD "first" ["second"], TD "second" ["third"], TD "third" []], "first", Forward, ["third", "second"]) + , ([TD "first" ["second"], TD "second" ["third"], TD "third" [], TD "fourth" ["third"]] + , "first", Forward, ["third", "second"]) + , ([TD "first" [], TD "second" ["first"]] + , "first", Reverse, ["second"]) + , ([TD "first" [], TD "second" ["first"], TD "third" ["second"]] + , "first", Reverse, ["third", "second"]) + , ([TD "first" [], TD "second" ["first"], TD "third" ["second"], TD "fourth" ["second"]] + , "first", Reverse, ["fourth", "third", "second"]) + , ([ TD "first" ["second"], TD "second" ["third"], TD "third" ["fourth"] + , TD "second" ["fifth"], TD "fifth" ["third"], TD "fourth" []] + , "fourth", Reverse, ["first", "second", "fifth", "third"]) + , ([ TD "first" ["second"], TD "second" ["third", "fifth"], TD "third" ["fourth"] + , TD "fifth" ["third"], TD "fourth" []] + , "first", Forward, ["fourth", "third", "fifth", "second"]) + ] + +fromRight :: Either a b -> b +fromRight (Left _) = error "Got a Left value" +fromRight (Right v) = v + +mkDependencyTest :: DependencyTestCase -> Test +mkDependencyTest testCase@(deps, a, dir, expected) = + let f = case dir of + Forward -> dependencies + Reverse -> reverseDependencies + in (show testCase) ~: expected ~=? f (fromRight $ mkDepGraph deps) a + +dependencyTests :: [Test] +dependencyTests = map mkDependencyTest dependencyTestCases diff --git a/test/FilesystemParseTest.hs b/test/FilesystemParseTest.hs new file mode 100644 --- /dev/null +++ b/test/FilesystemParseTest.hs @@ -0,0 +1,117 @@ +module FilesystemParseTest + ( tests + ) +where + +import Test.HUnit +import Data.Time.Clock ( UTCTime ) +import System.FilePath ( () ) + +import Common + +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Filesystem + ( FilesystemStore(..) + , migrationFromFile + ) + +tests :: IO [Test] +tests = migrationParsingTests + +-- filename, result +type MigrationParsingTestCase = (FilePath, Either String Migration) + +tsStr :: String +tsStr = "2009-04-15 10:02:06 UTC" + +ts :: UTCTime +ts = read tsStr + +valid_full :: Migration +valid_full = Migration { + mTimestamp = ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = "CREATE TABLE test ( a int );" + , mRevert = Just "DROP TABLE test;" + } + +valid_full_comments :: Migration +valid_full_comments = Migration { + mTimestamp = ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = "\n-- Comment on a line\nCREATE TABLE test (\n a int -- comment inline\n);\n" + , mRevert = Just "DROP TABLE test;" + } + +valid_full_colon :: Migration +valid_full_colon = Migration { + mTimestamp = ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = "\n-- Comment on a line with a colon:\nCREATE TABLE test (\n a int\n);\n" + , mRevert = Just "DROP TABLE test;" + } + +testStorePath :: FilePath +testStorePath = testFile $ "migration_parsing" + +fp :: FilePath -> FilePath +fp = (testStorePath ) + +migrationParsingTestCases :: [MigrationParsingTestCase] +migrationParsingTestCases = [ ("valid_full", Right valid_full) + , ("valid_with_comments" + , Right (valid_full { mId = "valid_with_comments" })) + , ("valid_with_comments2" + , Right (valid_full_comments { mId = "valid_with_comments2" })) + , ("valid_with_colon" + , Right (valid_full_colon { mId = "valid_with_colon" })) + , ("valid_with_multiline_deps" + , Right (valid_full { mId = "valid_with_multiline_deps" + , mDeps = ["one", "two", "three"] } )) + , ("valid_no_depends" + , Right (valid_full { mId = "valid_no_depends", mDeps = [] })) + , ("valid_no_desc" + , Right (valid_full { mId = "valid_no_desc", mDesc = Nothing })) + , ("valid_no_revert" + , Right (valid_full { mId = "valid_no_revert", mRevert = Nothing })) + , ("invalid_missing_required_fields" + , Left $ "Could not parse migration " ++ + (fp "invalid_missing_required_fields.txt") ++ + ":Error in " ++ + (show $ fp "invalid_missing_required_fields.txt") ++ + ": missing required field(s): " ++ + "[\"Created\",\"Depends\"]") + , ("invalid_field_name" + , Left $ "Could not parse migration " ++ + (fp "invalid_field_name.txt") ++ + ":Error in " ++ + (show $ fp "invalid_field_name.txt") ++ + ": unrecognized field found") + , ("invalid_syntax" + , Left $ "Could not parse migration " ++ + (fp "invalid_syntax.txt") ++ + ":user error (syntax error: line 7, " ++ + "column 0)") + , ("invalid_timestamp" + , Left $ "Could not parse migration " ++ + (fp "invalid_timestamp.txt") ++ + ":Error in " ++ + (show $ fp "invalid_timestamp.txt") ++ + ": unrecognized field found") + ] + +mkParsingTest :: MigrationParsingTestCase -> IO Test +mkParsingTest (fname, expected) = do + let store = FSStore { storePath = testStorePath } + actual <- migrationFromFile store fname + return $ test $ expected ~=? actual + +migrationParsingTests :: IO [Test] +migrationParsingTests = + sequence $ map mkParsingTest migrationParsingTestCases diff --git a/test/FilesystemSerializeTest.hs b/test/FilesystemSerializeTest.hs new file mode 100644 --- /dev/null +++ b/test/FilesystemSerializeTest.hs @@ -0,0 +1,74 @@ +module FilesystemSerializeTest + ( tests + ) +where + +import Test.HUnit +import Data.Time.Clock ( UTCTime ) + +import Database.Schema.Migrations.Filesystem.Serialize +import Database.Schema.Migrations.Migration + +tests :: [Test] +tests = serializationTests + +mkSerializationTest :: (Migration, String) -> Test +mkSerializationTest (m, expectedString) = test $ expectedString ~=? serializeMigration m + +tsStr :: String +tsStr = "2009-04-15 10:02:06 UTC" + +ts :: UTCTime +ts = read tsStr + +valid_full :: Migration +valid_full = Migration { + mTimestamp = ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = " CREATE TABLE test (\n a int\n );\n" + , mRevert = Just "DROP TABLE test;" + } + +serializationTestCases :: [(Migration, String)] +serializationTestCases = [ (valid_full, "Description: A valid full migration.\n\ + \Created: " ++ tsStr ++ "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n") + , (valid_full { mDesc = Nothing } + , "Created: " ++ tsStr ++ "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n") + , (valid_full { mDeps = ["one", "two"] } + , "Description: A valid full migration.\n\ + \Created: " ++ tsStr ++ "\n\ + \Depends: one two\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n") + , (valid_full { mRevert = Nothing } + , "Description: A valid full migration.\n\ + \Created: " ++ tsStr ++ "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n") + ] + +serializationTests :: [Test] +serializationTests = map mkSerializationTest serializationTestCases diff --git a/test/FilesystemTest.hs b/test/FilesystemTest.hs new file mode 100644 --- /dev/null +++ b/test/FilesystemTest.hs @@ -0,0 +1,33 @@ +module FilesystemTest + ( tests + ) +where + +import Database.Schema.Migrations.Filesystem +import Database.Schema.Migrations.Store ( MigrationStore(..) ) + +import Test.HUnit +import qualified Data.Set as Set +import Common + +tests :: IO [Test] +tests = sequence [getMigrationsTest] + +getMigrationsTest :: IO Test +getMigrationsTest = do + let store = FSStore { storePath = testFile "migration_parsing" } + expected = Set.fromList [ "invalid_field_name" + , "invalid_missing_required_fields" + , "invalid_syntax" + , "invalid_timestamp" + , "valid_full" + , "valid_no_depends" + , "valid_no_desc" + , "valid_no_revert" + , "valid_with_comments" + , "valid_with_comments2" + , "valid_with_colon" + , "valid_with_multiline_deps" + ] + migrations <- getMigrations store + return $ expected ~=? Set.fromList migrations diff --git a/test/MigrationsTest.hs b/test/MigrationsTest.hs new file mode 100644 --- /dev/null +++ b/test/MigrationsTest.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TypeSynonymInstances,GeneralizedNewtypeDeriving,MultiParamTypeClasses,FlexibleInstances #-} +module MigrationsTest + ( tests + ) +where + +import Test.HUnit +import Control.Monad.Identity ( runIdentity, Identity ) +import qualified Data.Map as Map +import Data.Time.Clock ( UTCTime ) + +import Database.Schema.Migrations +import Database.Schema.Migrations.Store +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Backend + +tests :: [Test] +tests = migrationsToApplyTests + +type TestBackend = [Migration] + +newtype TestM a = TestM (Identity a) deriving (Monad) + +instance MonadMigration TestM where + getCurrentTime = undefined + +instance Backend TestBackend TestM where + getBootstrapMigration _ = undefined + isBootstrapped _ = return True + applyMigration _ _ = undefined + revertMigration _ _ = undefined + getMigrations b = return $ map mId b + +-- |Given a backend and a store, what are the list of migrations +-- missing in the backend that are available in the store? +type MissingMigrationTestCase = (MigrationMap, TestBackend, Migration, + [Migration]) + +ts :: UTCTime +ts = read "2009-04-15 10:02:06 UTC" + +blankMigration :: Migration +blankMigration = Migration { mTimestamp = ts + , mId = undefined + , mDesc = Nothing + , mApply = "" + , mRevert = Nothing + , mDeps = [] + } + +missingMigrationsTestcases :: [MissingMigrationTestCase] +missingMigrationsTestcases = [ (m, [], one, [one]) + , (m, [one], one, []) + , (m, [one], two, [two]) + , (m, [one, two], one, []) + , (m, [one, two], two, []) + ] + where + one = blankMigration { mId = "one" } + two = blankMigration { mId = "two", mDeps = ["one"] } + m = Map.fromList [ (mId e, e) | e <- [one, two] ] + +mkTest :: MissingMigrationTestCase -> Test +mkTest (mapping, backend, theMigration, expected) = + let Right graph = depGraphFromMapping mapping + storeData = StoreData mapping graph + TestM act = migrationsToApply storeData backend theMigration + result = runIdentity act + in expected ~=? result + +migrationsToApplyTests :: [Test] +migrationsToApplyTests = map mkTest missingMigrationsTestcases diff --git a/test/StoreTest.hs b/test/StoreTest.hs new file mode 100644 --- /dev/null +++ b/test/StoreTest.hs @@ -0,0 +1,118 @@ +module StoreTest + ( tests + ) +where + +import Test.HUnit +import qualified Data.Map as Map + +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store + +tests :: [Test] +tests = validateSingleMigrationTests + ++ validateMigrationMapTests + +type ValidateSingleTestCase = ( MigrationMap + , Migration + , [MapValidationError] + ) + +type ValidateMigrationMapTestCase = ( MigrationMap + , [MapValidationError] + ) + +emptyMap :: MigrationMap +emptyMap = Map.fromList [] + +partialMap :: MigrationMap +partialMap = Map.fromList [ ("one", undefined) + , ("three", undefined) + ] + +fullMap :: MigrationMap +fullMap = Map.fromList [ ("one", undefined) + , ("two", undefined) + , ("three", undefined) + ] + +withDeps :: Migration +withDeps = Migration { mTimestamp = undefined + , mId = "with_deps" + , mDesc = Just "with dependencies" + , mApply = "" + , mRevert = Nothing + , mDeps = ["one", "two", "three"] + } + +noDeps :: Migration +noDeps = Migration { mTimestamp = undefined + , mId = "no_deps" + , mDesc = Just "no dependencies" + , mApply = "" + , mRevert = Nothing + , mDeps = [] + } + +validateSingleTestCases :: [ValidateSingleTestCase] +validateSingleTestCases = [ (emptyMap, withDeps, [ DependencyReferenceError (mId withDeps) "one" + , DependencyReferenceError (mId withDeps) "two" + , DependencyReferenceError (mId withDeps) "three" + ] + ) + , (emptyMap, noDeps, []) + , (partialMap, withDeps, [DependencyReferenceError (mId withDeps) "two"]) + , (fullMap, withDeps, []) + , (fullMap, noDeps, []) + ] + +validateSingleMigrationTests :: [Test] +validateSingleMigrationTests = + map mkValidateSingleTest validateSingleTestCases + where + mkValidateSingleTest (mmap, m, errs) = + errs ~=? validateSingleMigration mmap m + +m1 :: Migration +m1 = noDeps { mId = "m1" + , mDeps = [] } + +m2 :: Migration +m2 = noDeps { mId = "m2" + , mDeps = ["m1"] } + +m3 :: Migration +m3 = noDeps { mId = "m3" + , mDeps = ["nonexistent"] } + +m4 :: Migration +m4 = noDeps { mId = "m4" + , mDeps = ["one", "two"] } + +map1 :: MigrationMap +map1 = Map.fromList [ ("m1", m1) + , ("m2", m2) + ] + +map2 :: MigrationMap +map2 = Map.fromList [ ("m3", m3) + ] + +map3 :: MigrationMap +map3 = Map.fromList [ ("m4", m4) + ] + +validateMapTestCases :: [ValidateMigrationMapTestCase] +validateMapTestCases = [ (emptyMap, []) + , (map1, []) + , (map2, [DependencyReferenceError (mId m3) "nonexistent"]) + , (map3, [ DependencyReferenceError (mId m4) "one" + , DependencyReferenceError (mId m4) "two"]) + ] + +validateMigrationMapTests :: [Test] +validateMigrationMapTests = + map mkValidateMapTest validateMapTestCases + where + mkValidateMapTest (mmap, errs) = + errs ~=? validateMigrationMap mmap diff --git a/test/example_store/root b/test/example_store/root new file mode 100644 --- /dev/null +++ b/test/example_store/root @@ -0,0 +1,10 @@ +Description: The first migration in the store. +Created: 2009-04-15 10:02:06 UTC +Depends: +Apply: + + CREATE TABLE test (a int); + +Revert: + + DROP TABLE test; diff --git a/test/example_store/update1 b/test/example_store/update1 new file mode 100644 --- /dev/null +++ b/test/example_store/update1 @@ -0,0 +1,10 @@ +Description: Add another meaningless column to test. +Created: 2009-04-15 10:04:31 UTC +Depends: root +Apply: + + ALTER TABLE test ADD b int; + +Revert: + + ALTER TABLE test DROP COLUMN b; diff --git a/test/example_store/update2 b/test/example_store/update2 new file mode 100644 --- /dev/null +++ b/test/example_store/update2 @@ -0,0 +1,10 @@ +Description: Add a constraint on test.b. +Created: 2009-04-15 11:36:49 UTC +Depends: update1 +Apply: + + CREATE UNIQUE INDEX test_b_idx ON test(b); + +Revert: + + DROP INDEX test_b_idx; diff --git a/test/migration_parsing/invalid_field_name.txt b/test/migration_parsing/invalid_field_name.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/invalid_field_name.txt @@ -0,0 +1,11 @@ +Description: The first migration in the store. +InvalidField: bogus +Created: 2009-04-15 10:02:06 UTC +Depends: valid +Apply: + + CREATE TABLE test (a int); + +Revert: + + DROP TABLE test; diff --git a/test/migration_parsing/invalid_missing_required_fields.txt b/test/migration_parsing/invalid_missing_required_fields.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/invalid_missing_required_fields.txt @@ -0,0 +1,8 @@ +Description: A valid full migration. +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/test/migration_parsing/invalid_syntax.txt b/test/migration_parsing/invalid_syntax.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/invalid_syntax.txt @@ -0,0 +1,9 @@ +Description: The first migration in the store. +Created: 2009-04-15 10:02:06 UTC +Depends: valid +Apply: +CREATE TABLE test (a int); + +Revert: + + DROP TABLE test; diff --git a/test/migration_parsing/invalid_timestamp.txt b/test/migration_parsing/invalid_timestamp.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/invalid_timestamp.txt @@ -0,0 +1,10 @@ +Description: The first migration in the store. +Created: 209-41-15 :02:06 UTC +Depends: valid +Apply: + + CREATE TABLE test (a int); + +Revert: + + DROP TABLE test; diff --git a/test/migration_parsing/valid_full.txt b/test/migration_parsing/valid_full.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/valid_full.txt @@ -0,0 +1,10 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/test/migration_parsing/valid_no_depends.txt b/test/migration_parsing/valid_no_depends.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/valid_no_depends.txt @@ -0,0 +1,10 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/test/migration_parsing/valid_no_desc.txt b/test/migration_parsing/valid_no_desc.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/valid_no_desc.txt @@ -0,0 +1,9 @@ +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/test/migration_parsing/valid_no_revert.txt b/test/migration_parsing/valid_no_revert.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/valid_no_revert.txt @@ -0,0 +1,8 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); diff --git a/test/migration_parsing/valid_with_colon.txt b/test/migration_parsing/valid_with_colon.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/valid_with_colon.txt @@ -0,0 +1,11 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: | + + -- Comment on a line with a colon: + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/test/migration_parsing/valid_with_comments.txt b/test/migration_parsing/valid_with_comments.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/valid_with_comments.txt @@ -0,0 +1,13 @@ +# This is a test migration. It includes all fields with valid values +# and takes advantage of most parser corner-cases and features. + +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/test/migration_parsing/valid_with_comments2.txt b/test/migration_parsing/valid_with_comments2.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/valid_with_comments2.txt @@ -0,0 +1,11 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: | + + -- Comment on a line + CREATE TABLE test ( + a int -- comment inline + ); + +Revert: DROP TABLE test; diff --git a/test/migration_parsing/valid_with_multiline_deps.txt b/test/migration_parsing/valid_with_multiline_deps.txt new file mode 100644 --- /dev/null +++ b/test/migration_parsing/valid_with_multiline_deps.txt @@ -0,0 +1,15 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC + +Depends: + one + two + three + +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test;