diff --git a/MOO.TXT b/MOO.TXT --- a/MOO.TXT +++ b/MOO.TXT @@ -76,3 +76,9 @@ command would apply if you were to run it. In other words, this will list all migrations which have not yet been applied to the database. + + reinstall: this will revert, then reapply a migration, all in a + transaction. If --test is specified, the transaction will be + rolled back; otherwise it will be committed. This is mostly + useful in development when a migration applies but is incorrect + and needs to be tweaked and reapplied. diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 0.2 +Version: 0.3 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -34,10 +34,10 @@ Library if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Build-Depends: base >= 4 && < 5, @@ -75,10 +75,10 @@ process >= 1.0 && < 1.1 if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -Wwarn else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields if !flag(testing) Buildable: False @@ -92,10 +92,10 @@ HDBC-sqlite3 if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields Hs-Source-Dirs: src Main-is: Moo.hs diff --git a/src/Database/Schema/Migrations/Backend.hs b/src/Database/Schema/Migrations/Backend.hs --- a/src/Database/Schema/Migrations/Backend.hs +++ b/src/Database/Schema/Migrations/Backend.hs @@ -1,11 +1,18 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Database.Schema.Migrations.Backend ( Backend(..) + , rootMigrationName ) where import Database.Schema.Migrations.Migration ( Migration(..) ) + +-- |Backend instances should use this as the name of the migration +-- returned by getBootstrapMigration; this migration is special +-- because it cannot be reverted. +rootMigrationName :: String +rootMigrationName = "root" -- |A Backend represents a database engine backend such as MySQL or -- SQLite. A Backend supplies relatively low-level functions for diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs --- a/src/Database/Schema/Migrations/Backend/HDBC.hs +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -7,7 +7,9 @@ import Database.HDBC ( quickQuery', fromSql, toSql, IConnection(getTables, run, runRaw) ) import Database.Schema.Migrations.Backend - ( Backend(..) ) + ( Backend(..) + , rootMigrationName + ) import Database.Schema.Migrations.Migration ( Migration(..) , newMigration @@ -33,7 +35,7 @@ getBootstrapMigration _ = do - m <- newMigration "root" + m <- newMigration rootMigrationName return $ m { mApply = createSql , mRevert = Just revertSql , mDesc = Just "Migration table installation" diff --git a/src/Moo.hs b/src/Moo.hs --- a/src/Moo.hs +++ b/src/Moo.hs @@ -25,7 +25,8 @@ import Database.Schema.Migrations.Filesystem import Database.Schema.Migrations.Migration ( Migration(..) ) import Database.Schema.Migrations.Backend ( Backend, applyMigration - , revertMigration + , revertMigration, getMigrations + , rootMigrationName ) import Database.Schema.Migrations.Store ( loadMigrations , fullMigrationName @@ -170,10 +171,10 @@ commands = [ Command "new" ["migration_name"] [] [NoAsk] "Create a new empty migration" newCommand - , Command "apply" ["migration_name"] [] [] + , Command "apply" ["migration_name"] [] [Test] "Apply the specified migration and its dependencies" applyCommand - , Command "revert" ["migration_name"] [] [] + , Command "revert" ["migration_name"] [] [Test] "Revert the specified migration and those that depend\ \ on it" revertCommand @@ -186,9 +187,14 @@ \installed" upgradeCommand , Command "upgrade-list" [] [] [] - "Show the list of migrations to be installed during \ - \an upgrade" + "Show the list of migrations not yet installed" upgradeListCommand + , Command "reinstall" ["migration_name"] [] [Test] + "Reinstall a migration by reverting, then reapplying it" + reinstallCommand + , Command "list" [] [] [] + "List migrations already installed in the backend" + listCommand ] -- The values of DBM_DATABASE_TYPE and their corresponding connection @@ -340,7 +346,7 @@ exitSuccess forM_ migrationNames $ \migrationName -> do m <- lookupMigration storeData migrationName - apply m storeData conn + apply m storeData conn False case isTesting of True -> do rollback conn @@ -366,8 +372,8 @@ exitWith (ExitFailure 1) apply :: (IConnection b, Backend b IO) - => Migration -> StoreData -> b -> IO [Migration] -apply m storeData backend = do + => Migration -> StoreData -> b -> Bool -> IO [Migration] +apply m storeData backend complain = do -- Get the list of migrations to apply toApply <- migrationsToApply storeData backend m @@ -378,9 +384,10 @@ where nothingToDo = do - putStrLn $ "Nothing to do; " ++ - (mId m) ++ - " already installed." + when complain $ + putStrLn $ "Nothing to do; " ++ + (mId m) ++ + " already installed." applyIt conn it = do putStr $ "Applying: " ++ mId it ++ "... " @@ -418,20 +425,56 @@ exitWith (ExitFailure 1) Just m' -> return m' +reinstallCommand :: CommandHandler +reinstallCommand storeData = do + isTesting <- hasOption Test + required <- asks appRequiredArgs + let [migrationId] = required + + withConnection $ \(AnyIConnection conn) -> do + ensureBootstrappedBackend conn >> commit conn + m <- lookupMigration storeData migrationId + + revert m storeData conn + apply m storeData conn True + + case isTesting of + False -> do + commit conn + putStrLn "Migration successfully reinstalled." + True -> do + rollback conn + putStrLn "Reinstall test successful." + +listCommand :: CommandHandler +listCommand _ = do + withConnection $ \(AnyIConnection conn) -> do + ensureBootstrappedBackend conn >> commit conn + ms <- getMigrations conn + forM_ ms $ \m -> + when (not $ m == rootMigrationName) $ putStrLn m + applyCommand :: CommandHandler applyCommand storeData = do + isTesting <- hasOption Test required <- asks appRequiredArgs let [migrationId] = required withConnection $ \(AnyIConnection conn) -> do ensureBootstrappedBackend conn >> commit conn m <- lookupMigration storeData migrationId - apply m storeData conn - commit conn - putStrLn "Successfully applied migrations." + apply m storeData conn True + case isTesting of + False -> do + commit conn + putStrLn "Successfully applied migrations." + True -> do + rollback conn + putStrLn "Migration installation test successful." revertCommand :: CommandHandler revertCommand storeData = do + isTesting <- hasOption Test required <- asks appRequiredArgs let [migrationId] = required @@ -439,9 +482,15 @@ ensureBootstrappedBackend conn >> commit conn m <- lookupMigration storeData migrationId revert m storeData conn - commit conn - putStrLn "Successfully reverted migrations." + case isTesting of + False -> do + commit conn + putStrLn "Successfully reverted migrations." + True -> do + rollback conn + putStrLn "Migration uninstallation test successful." + testCommand :: CommandHandler testCommand storeData = do required <- asks appRequiredArgs @@ -456,7 +505,7 @@ when (not $ migrationId `elem` migrationNames) $ do revert m storeData conn return () - applied <- apply m storeData conn + applied <- apply m storeData conn True forM_ (reverse applied) $ \migration -> do revert migration storeData conn rollback conn