diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 0.8.2 +Version: 0.9 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -85,15 +85,15 @@ Database.Schema.Migrations.Backend.HDBC Database.Schema.Migrations.Store Moo.Main - - Other-Modules: - Database.Schema.Migrations.CycleDetection - Database.Schema.Migrations.Filesystem.Serialize Moo.CommandHandlers Moo.CommandInterface Moo.CommandUtils Moo.Core + Other-Modules: + Database.Schema.Migrations.CycleDetection + Database.Schema.Migrations.Filesystem.Serialize + test-suite dbmigrations-tests default-language: Haskell2010 type: exitcode-stdio-1.0 @@ -140,21 +140,8 @@ default-language: Haskell2010 Build-Depends: base >= 4 && < 5, - HDBC >= 2.2.1, - 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, - bytestring >= 0.9, - text >= 0.11, configurator >= 0.2, - HDBC-postgresql, - HDBC-sqlite3 + dbmigrations if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields @@ -162,5 +149,5 @@ else ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields - Hs-Source-Dirs: src + Hs-Source-Dirs: programs Main-is: Moo.hs diff --git a/programs/Moo.hs b/programs/Moo.hs new file mode 100644 --- /dev/null +++ b/programs/Moo.hs @@ -0,0 +1,20 @@ +module Main + ( main + ) +where + +import Prelude hiding (lookup) +import System.Environment (getArgs) +import System.Exit + +import Moo.Core +import Moo.Main + +main :: IO () +main = do + args <- getArgs + (_, opts, _) <- procArgs args + conf <- loadConfiguration $ _configFilePath opts + case conf of + Left e -> putStrLn e >> exitFailure + Right c -> mainWithConf args c diff --git a/src/Database/Schema/Migrations.hs b/src/Database/Schema/Migrations.hs --- a/src/Database/Schema/Migrations.hs +++ b/src/Database/Schema/Migrations.hs @@ -21,13 +21,12 @@ import Database.Schema.Migrations.Migration ( Migration(..) , newMigration - , MonadMigration ) -- |Given a 'B.Backend' and a 'S.MigrationMap', query the backend and -- return a list of migration names which are available in the -- 'S.MigrationMap' but which are not installed in the 'B.Backend'. -missingMigrations :: (B.Backend b m) => b -> S.StoreData -> m [String] +missingMigrations :: B.Backend -> S.StoreData -> IO [String] missingMigrations backend storeData = do let storeMigrationNames = map mId $ S.storeMigrations storeData backendMigrations <- B.getMigrations backend @@ -36,34 +35,25 @@ (Set.fromList storeMigrationNames) (Set.fromList backendMigrations) --- |Create a new migration and store it in the 'S.MigrationStore', --- with some of its fields initially set to defaults. -createNewMigration :: (MonadMigration m, S.MigrationStore s m) - => s -- ^ The 'S.MigrationStore' in which to create a new migration - -> String -- ^ The name of the new migration to create - -> [String] -- ^ The list of migration names on which the new migration should depend - -> m (Either String Migration) -createNewMigration store name deps = do +-- |Create a new migration and store it in the 'S.MigrationStore'. +createNewMigration :: S.MigrationStore -- ^ The 'S.MigrationStore' in which to create a new migration + -> Migration -- ^ The new migration + -> IO (Either String Migration) +createNewMigration store newM = do available <- S.getMigrations store - case name `elem` available of + case mId newM `elem` available of True -> do - fullPath <- S.fullMigrationName store name + fullPath <- S.fullMigrationName store (mId newM) return $ Left $ "Migration " ++ (show fullPath) ++ " already exists" False -> do - new <- newMigration name - let newWithDefaults = new { mDesc = Just "(Description here.)" - , mApply = "(Apply SQL here.)" - , mRevert = Just "(Revert SQL here.)" - , mDeps = deps - } - S.saveMigration store newWithDefaults - return $ Right newWithDefaults + S.saveMigration store newM + return $ Right newM -- |Given a 'B.Backend', ensure that the backend is ready for use by -- bootstrapping it. This entails installing the appropriate database -- elements to track installed migrations. If the backend is already -- bootstrapped, this has no effect. -ensureBootstrappedBackend :: (B.Backend b m) => b -> m () +ensureBootstrappedBackend :: B.Backend -> IO () ensureBootstrappedBackend backend = do bsStatus <- B.isBootstrapped backend case bsStatus of @@ -73,8 +63,8 @@ -- |Given a migration mapping computed from a MigrationStore, a -- backend, and a migration to apply, return a list of migrations to -- apply, in order. -migrationsToApply :: (B.Backend b m) => S.StoreData -> b - -> Migration -> m [Migration] +migrationsToApply :: S.StoreData -> B.Backend + -> Migration -> IO [Migration] migrationsToApply storeData backend migration = do let graph = S.storeDataGraph storeData @@ -89,8 +79,8 @@ -- |Given a migration mapping computed from a MigrationStore, a -- backend, and a migration to revert, return a list of migrations to -- revert, in order. -migrationsToRevert :: (B.Backend b m) => S.StoreData -> b - -> Migration -> m [Migration] +migrationsToRevert :: S.StoreData -> B.Backend + -> Migration -> IO [Migration] migrationsToRevert storeData backend migration = do let graph = S.storeDataGraph storeData 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,4 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} module Database.Schema.Migrations.Backend ( Backend(..) , rootMigrationName @@ -20,39 +19,53 @@ -- migrations. A Backend also supplies the migration necessary to -- "bootstrap" a backend so that it can track which migrations are -- installed. -class (Monad m) => Backend b m where - -- |The migration necessary to bootstrap a database with this - -- connection interface. This might differ slightly from one - -- backend to another. - getBootstrapMigration :: b -> m Migration +data Backend = + Backend { getBootstrapMigration :: IO Migration + -- ^ The migration necessary to bootstrap a database with + -- this connection interface. This might differ slightly + -- from one backend to another. - -- |Returns whether the backend has been bootstrapped. A backend - -- has been bootstrapped if is capable of tracking which - -- migrations have been installed; the "bootstrap migration" - -- provided by getBootstrapMigration should suffice to bootstrap - -- the backend. - isBootstrapped :: b -> m Bool + , isBootstrapped :: IO Bool + -- ^ Returns whether the backend has been bootstrapped. A + -- backend has been bootstrapped if is capable of tracking + -- which migrations have been installed; the "bootstrap + -- migration" provided by getBootstrapMigration should + -- suffice to bootstrap the backend. - -- |Apply the specified migration on the backend. applyMigration - -- does NOT assume control of the transaction, since it expects - -- the transaction to (possibly) cover more than one - -- applyMigration operation. The caller is expected to call - -- commit at the appropriate time. If the application fails, the - -- underlying SqlError is raised and a manual rollback may be - -- necessary; for this, see withTransaction from HDBC. - applyMigration :: b -> Migration -> m () + , applyMigration :: Migration -> IO () + -- ^ Apply the specified migration on the backend. + -- applyMigration does NOT assume control of the + -- transaction, since it expects the transaction to + -- (possibly) cover more than one applyMigration operation. + -- The caller is expected to call commit at the appropriate + -- time. If the application fails, the underlying SqlError + -- is raised and a manual rollback may be necessary; for + -- this, see withTransaction from HDBC. - -- |Revert the specified migration from the backend and record - -- this action in the table which tracks installed migrations. - -- revertMigration does NOT assume control of the transaction, - -- since it expects the transaction to (possibly) cover more than - -- one revertMigration operation. The caller is expected to call - -- commit at the appropriate time. If the revert fails, the - -- underlying SqlError is raised and a manual rollback may be - -- necessary; for this, see withTransaction from HDBC. If the - -- specified migration does not supply a revert instruction, this - -- has no effect other than bookkeeping. - revertMigration :: b -> Migration -> m () + , revertMigration :: Migration -> IO () + -- ^ Revert the specified migration from the backend and + -- record this action in the table which tracks installed + -- migrations. revertMigration does NOT assume control of + -- the transaction, since it expects the transaction to + -- (possibly) cover more than one revertMigration operation. + -- The caller is expected to call commit at the appropriate + -- time. If the revert fails, the underlying SqlError is + -- raised and a manual rollback may be necessary; for this, + -- see withTransaction from HDBC. If the specified migration + -- does not supply a revert instruction, this has no effect + -- other than bookkeeping. - -- |Returns a list of installed migration names from the backend. - getMigrations :: b -> m [String] + , getMigrations :: IO [String] + -- ^ Returns a list of installed migration names from the + -- backend. + + , commitBackend :: IO () + -- ^ Commit changes to the backend. + + , rollbackBackend :: IO () + -- ^ Revert changes made to the backend since the current + -- transaction began. + + , disconnectBackend :: IO () + -- ^ Disconnect from the backend. + } 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 @@ -1,10 +1,17 @@ -{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Schema.Migrations.Backend.HDBC - () + ( hdbcBackend + ) where -import Database.HDBC ( quickQuery', fromSql, toSql, IConnection(getTables, run, runRaw) ) +import Database.HDBC + ( quickQuery' + , fromSql + , toSql + , IConnection(getTables, run, runRaw) + , commit + , rollback + , disconnect + ) import Database.Schema.Migrations.Backend ( Backend(..) @@ -16,6 +23,7 @@ ) import Control.Applicative ( (<$>) ) +import Data.Time.Clock (getCurrentTime) migrationTableName :: String migrationTableName = "installed_migrations" @@ -26,36 +34,42 @@ revertSql :: String revertSql = "DROP TABLE " ++ migrationTableName --- |General Backend instance for all IO-driven HDBC connection --- implementations. You can provide a connection-specific instance if --- need be; this implementation is provided with the hope that you --- won't /have/ to do that. -instance (IConnection conn) => Backend conn IO where - isBootstrapped conn = elem migrationTableName <$> getTables conn +-- |General Backend constructor for all HDBC connection implementations. +hdbcBackend :: (IConnection conn) => conn -> Backend +hdbcBackend conn = + Backend { isBootstrapped = elem migrationTableName <$> getTables conn + , getBootstrapMigration = + do + ts <- getCurrentTime + return $ (newMigration rootMigrationName) + { mApply = createSql + , mRevert = Just revertSql + , mDesc = Just "Migration table installation" + , mTimestamp = Just ts + } - getBootstrapMigration _ = - do - m <- newMigration rootMigrationName - return $ m { mApply = createSql - , mRevert = Just revertSql - , mDesc = Just "Migration table installation" - } + , applyMigration = \m -> do + runRaw conn (mApply m) + run conn ("INSERT INTO " ++ migrationTableName ++ + " (migration_id) VALUES (?)") [toSql $ mId m] + return () - applyMigration conn m = do - runRaw conn (mApply m) - run conn ("INSERT INTO " ++ migrationTableName ++ - " (migration_id) VALUES (?)") [toSql $ mId m] - return () + , revertMigration = \m -> do + case mRevert m of + Nothing -> return () + Just query -> runRaw conn query + -- Remove migration from installed_migrations in either case. + run conn ("DELETE FROM " ++ migrationTableName ++ + " WHERE migration_id = ?") [toSql $ mId m] + return () - revertMigration conn m = do - case mRevert m of - Nothing -> return () - Just query -> runRaw conn query - -- Remove migration from installed_migrations in either case. - run conn ("DELETE FROM " ++ migrationTableName ++ - " WHERE migration_id = ?") [toSql $ mId m] - return () + , getMigrations = do + results <- quickQuery' conn ("SELECT migration_id FROM " ++ migrationTableName) [] + return $ map (fromSql . head) results - getMigrations conn = do - results <- quickQuery' conn ("SELECT migration_id FROM " ++ migrationTableName) [] - return $ map (fromSql . head) results + , commitBackend = commit conn + + , rollbackBackend = rollback conn + + , disconnectBackend = disconnect conn + } diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} -- |This module provides a type for interacting with a -- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem - ( FilesystemStore(..) + ( FilesystemStoreSettings(..) , migrationFromFile , migrationFromPath + , filesystemStore ) where @@ -13,7 +14,6 @@ import System.Directory ( getDirectoryContents, doesFileExist ) import System.FilePath ( (), takeExtension, dropExtension , takeFileName, takeBaseName ) -import Control.Monad.Trans ( MonadIO, liftIO ) import Data.ByteString.Char8 ( unpack ) import Data.Typeable ( Typeable ) @@ -36,7 +36,7 @@ type FieldProcessor = String -> Migration -> Maybe Migration -data FilesystemStore = FSStore { storePath :: FilePath } +data FilesystemStoreSettings = FSStore { storePath :: FilePath } data FilesystemStoreError = FilesystemStoreError String deriving (Show, Typeable) @@ -49,32 +49,36 @@ filenameExtension :: String filenameExtension = ".txt" -instance (MonadIO m) => MigrationStore FilesystemStore m where - fullMigrationName s name = - return $ storePath s name ++ filenameExtension +filesystemStore :: FilesystemStoreSettings -> MigrationStore +filesystemStore s = + MigrationStore { fullMigrationName = fsFullMigrationName s - loadMigration s theId = liftIO $ migrationFromFile s theId + , loadMigration = \theId -> migrationFromFile s theId - getMigrations s = do - contents <- liftIO $ getDirectoryContents $ storePath s - let migrationFilenames = [ f | f <- contents, isMigrationFilename f ] - fullPaths = [ (f, storePath s f) | f <- migrationFilenames ] - existing <- liftIO $ filterM (\(_, full) -> doesFileExist full) fullPaths - return [ dropExtension short | (short, _) <- existing ] + , getMigrations = do + contents <- getDirectoryContents $ storePath s + let migrationFilenames = [ f | f <- contents, isMigrationFilename f ] + fullPaths = [ (f, storePath s f) | f <- migrationFilenames ] + existing <- filterM (\(_, full) -> doesFileExist full) fullPaths + return [ dropExtension short | (short, _) <- existing ] - saveMigration s m = do - filename <- fullMigrationName s $ mId m - liftIO $ writeFile filename $ serializeMigration m + , saveMigration = \m -> do + filename <- fsFullMigrationName s $ mId m + writeFile filename $ serializeMigration m + } +fsFullMigrationName :: FilesystemStoreSettings -> FilePath -> IO FilePath +fsFullMigrationName s name = return $ storePath s name ++ filenameExtension + isMigrationFilename :: FilePath -> Bool isMigrationFilename path = takeExtension path == filenameExtension -- |Given a store and migration name, read and parse the associated -- migration and return the migration if successful. Otherwise return -- a parsing error message. -migrationFromFile :: FilesystemStore -> String -> IO (Either String Migration) +migrationFromFile :: FilesystemStoreSettings -> String -> IO (Either String Migration) migrationFromFile store name = - fullMigrationName store name >>= migrationFromPath + fsFullMigrationName store name >>= migrationFromPath -- |Given a filesystem path, read and parse the file as a migration -- return the 'Migration' if successful. Otherwise return a parsing @@ -94,10 +98,10 @@ case length missing of 0 -> do - newM <- newMigration "" + let newM = newMigration name case migrationFromFields newM fields of Nothing -> throwFS $ "Error in " ++ (show path) ++ ": unrecognized field found" - Just m -> return $ m { mId = name } + Just m -> return m _ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing) getFields :: YamlLight -> [(String, String)] @@ -123,8 +127,7 @@ migrationFromFields newM rest requiredFields :: [String] -requiredFields = [ "Created" - , "Apply" +requiredFields = [ "Apply" , "Depends" ] @@ -141,7 +144,7 @@ ts <- case readTimestamp value of [(t, _)] -> return t _ -> fail "expected one valid parse" - return $ m { mTimestamp = ts } + return $ m { mTimestamp = Just ts } readTimestamp :: String -> [(UTCTime, String)] readTimestamp = reads diff --git a/src/Database/Schema/Migrations/Filesystem/Serialize.hs b/src/Database/Schema/Migrations/Filesystem/Serialize.hs --- a/src/Database/Schema/Migrations/Filesystem/Serialize.hs +++ b/src/Database/Schema/Migrations/Filesystem/Serialize.hs @@ -28,7 +28,10 @@ Just desc -> Just $ "Description: " ++ desc serializeTimestamp :: FieldSerializer -serializeTimestamp m = Just $ "Created: " ++ (show $ mTimestamp m) +serializeTimestamp m = + case mTimestamp m of + Nothing -> Nothing + Just ts -> Just $ "Created: " ++ (show ts) serializeDepends :: FieldSerializer serializeDepends m = Just $ "Depends: " ++ (intercalate " " $ mDeps m) diff --git a/src/Database/Schema/Migrations/Migration.hs b/src/Database/Schema/Migrations/Migration.hs --- a/src/Database/Schema/Migrations/Migration.hs +++ b/src/Database/Schema/Migrations/Migration.hs @@ -1,6 +1,5 @@ module Database.Schema.Migrations.Migration ( Migration(..) - , MonadMigration(..) , newMigration ) where @@ -10,7 +9,7 @@ import Data.Time () -- for UTCTime Show instance import qualified Data.Time.Clock as Clock -data Migration = Migration { mTimestamp :: Clock.UTCTime +data Migration = Migration { mTimestamp :: Maybe Clock.UTCTime , mId :: String , mDesc :: Maybe String , mApply :: String @@ -23,19 +22,12 @@ depsOf = mDeps depId = mId -class (Monad m) => MonadMigration m where - getCurrentTime :: m Clock.UTCTime - -instance MonadMigration IO where - getCurrentTime = Clock.getCurrentTime - -newMigration :: (MonadMigration m) => String -> m Migration -newMigration theId = do - curTime <- getCurrentTime - return $ Migration { mTimestamp = curTime - , mId = theId - , mDesc = Nothing - , mApply = "" - , mRevert = Nothing - , mDeps = [] - } +newMigration :: String -> Migration +newMigration theId = + Migration { mTimestamp = Nothing + , mId = theId + , mApply = "(Apply SQL here.)" + , mRevert = Nothing + , mDesc = Nothing + , mDeps = [] + } diff --git a/src/Database/Schema/Migrations/Store.hs b/src/Database/Schema/Migrations/Store.hs --- a/src/Database/Schema/Migrations/Store.hs +++ b/src/Database/Schema/Migrations/Store.hs @@ -45,25 +45,26 @@ , storeDataGraph :: DependencyGraph Migration } --- |A type class for types which represent a storage facility (and a --- monad context in which to operate on the store). A MigrationStore --- is a facility in which new migrations can be created, and from --- which existing migrations can be loaded. -class (Monad m) => MigrationStore s m where - -- |Load a migration from the store. - loadMigration :: s -> String -> m (Either String Migration) +-- |The type of migration storage facilities. A MigrationStore is a +-- facility in which new migrations can be created, and from which +-- existing migrations can be loaded. +data MigrationStore = + MigrationStore { loadMigration :: String -> IO (Either String Migration) + -- ^ Load a migration from the store. - -- |Save a migration to the store. - saveMigration :: s -> Migration -> m () + , saveMigration :: Migration -> IO () + -- ^ Save a migration to the store. - -- |Return a list of all available migrations' names. - getMigrations :: s -> m [String] + , getMigrations :: IO [String] + -- ^ Return a list of all available migrations' + -- names. - -- |Return the full representation of a given migration name; - -- mostly for filesystem stores, where the full representation - -- includes the store path. - fullMigrationName :: s -> String -> m String - fullMigrationName _ name = return name + , fullMigrationName :: String -> IO String + -- ^ Return the full representation of a given + -- migration name; mostly for filesystem stores, + -- where the full representation includes the store + -- path. + } -- |A type for types of validation errors for migration maps. data MapValidationError = DependencyReferenceError String String @@ -101,7 +102,7 @@ -- loaded migrations, and return errors or a 'MigrationMap' on -- success. Generally speaking, this will be the first thing you -- should call once you have constructed a 'MigrationStore'. -loadMigrations :: (MigrationStore s m) => s -> m (Either [MapValidationError] StoreData) +loadMigrations :: MigrationStore -> IO (Either [MapValidationError] StoreData) loadMigrations store = do migrations <- getMigrations store loadedWithErrors <- mapM (\name -> loadMigration store name) migrations diff --git a/src/Moo.hs b/src/Moo.hs deleted file mode 100644 --- a/src/Moo.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Main - ( main - ) -where - -import Control.Monad (liftM) -import Data.Configurator -import Prelude hiding (lookup) -import System.Environment (getArgs, getEnvironment) - -import Moo.Core -import Moo.Main - -loadConfiguration :: Maybe FilePath -> IO Configuration -loadConfiguration Nothing = liftM fromShellEnvironment getEnvironment -loadConfiguration (Just path) = fromConfigurator =<< load [Required path] - -main :: IO () -main = do - args <- getArgs - (_, opts, _) <- procArgs args - conf <- loadConfiguration $ _configFilePath opts - mainWithConf args conf diff --git a/src/Moo/CommandHandlers.hs b/src/Moo/CommandHandlers.hs --- a/src/Moo/CommandHandlers.hs +++ b/src/Moo/CommandHandlers.hs @@ -1,9 +1,9 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} - module Moo.CommandHandlers where +import Control.Applicative ((<$>)) import Moo.Core import Moo.CommandUtils import Control.Monad ( when, forM_ ) @@ -11,19 +11,18 @@ import Control.Monad.Reader ( asks ) import System.Exit ( exitWith, ExitCode(..), exitSuccess ) import Control.Monad.Trans ( liftIO ) -import Database.HDBC ( IConnection(commit, rollback)) import Database.Schema.Migrations.Store hiding (getMigrations) import Database.Schema.Migrations +import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Backend - newCommand :: CommandHandler newCommand storeData = do required <- asks _appRequiredArgs store <- asks _appStore let [migrationId] = required - noAsk <- fmap _noAsk $ asks _appOptions + noAsk <- _noAsk <$> asks _appOptions liftIO $ do fullPath <- fullMigrationName store migrationId @@ -45,7 +44,7 @@ case result of True -> do - status <- createNewMigration store migrationId deps + status <- createNewMigration store $ (newMigration migrationId) { mDeps = deps } case status of Left e -> putStrLn e >> (exitWith (ExitFailure 1)) Right _ -> putStrLn $ "Migration created successfully: " ++ @@ -53,126 +52,119 @@ False -> do putStrLn "Migration creation cancelled." - upgradeCommand :: CommandHandler upgradeCommand storeData = do - isTesting <- fmap _test $ asks _appOptions - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn - migrationNames <- missingMigrations conn storeData + isTesting <- _test <$> asks _appOptions + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + migrationNames <- missingMigrations backend storeData when (null migrationNames) $ do putStrLn "Database is up to date." exitSuccess forM_ migrationNames $ \migrationName -> do m <- lookupMigration storeData migrationName - apply m storeData conn False + apply m storeData backend False case isTesting of True -> do - rollback conn + rollbackBackend backend putStrLn "Upgrade test successful." False -> do - commit conn + commitBackend backend putStrLn "Database successfully upgraded." - upgradeListCommand :: CommandHandler upgradeListCommand storeData = do - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn - migrationNames <- missingMigrations conn storeData + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + migrationNames <- missingMigrations backend storeData when (null migrationNames) $ do putStrLn "Database is up to date." exitSuccess putStrLn "Migrations to install:" forM_ migrationNames (putStrLn . (" " ++)) - reinstallCommand :: CommandHandler reinstallCommand storeData = do - isTesting <- fmap _test $ asks _appOptions + isTesting <- _test <$> asks _appOptions required <- asks _appRequiredArgs let [migrationId] = required - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend m <- lookupMigration storeData migrationId - revert m storeData conn - apply m storeData conn True + revert m storeData backend + apply m storeData backend True case isTesting of False -> do - commit conn + commitBackend backend putStrLn "Migration successfully reinstalled." True -> do - rollback conn + rollbackBackend backend putStrLn "Reinstall test successful." - listCommand :: CommandHandler listCommand _ = do - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn - ms <- getMigrations conn + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + ms <- getMigrations backend forM_ ms $ \m -> when (not $ m == rootMigrationName) $ putStrLn m - applyCommand :: CommandHandler applyCommand storeData = do - isTesting <- fmap _test $ asks _appOptions + isTesting <- _test <$> asks _appOptions required <- asks _appRequiredArgs let [migrationId] = required - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend m <- lookupMigration storeData migrationId - apply m storeData conn True + apply m storeData backend True case isTesting of False -> do - commit conn + commitBackend backend putStrLn "Successfully applied migrations." True -> do - rollback conn + rollbackBackend backend putStrLn "Migration installation test successful." - revertCommand :: CommandHandler revertCommand storeData = do - isTesting <- fmap _test $ asks _appOptions + isTesting <- _test <$> asks _appOptions required <- asks _appRequiredArgs let [migrationId] = required - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend m <- lookupMigration storeData migrationId - revert m storeData conn + revert m storeData backend case isTesting of False -> do - commit conn + commitBackend backend putStrLn "Successfully reverted migrations." True -> do - rollback conn + rollbackBackend backend putStrLn "Migration uninstallation test successful." - testCommand :: CommandHandler testCommand storeData = do required <- asks _appRequiredArgs let [migrationId] = required - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend m <- lookupMigration storeData migrationId - migrationNames <- missingMigrations conn storeData + migrationNames <- missingMigrations backend storeData -- If the migration is already installed, remove it as part of -- the test when (not $ migrationId `elem` migrationNames) $ - do revert m storeData conn + do revert m storeData backend return () - applied <- apply m storeData conn True + applied <- apply m storeData backend True forM_ (reverse applied) $ \migration -> do - revert migration storeData conn - rollback conn + revert migration storeData backend + rollbackBackend backend putStrLn "Successfully tested migrations." diff --git a/src/Moo/CommandInterface.hs b/src/Moo/CommandInterface.hs --- a/src/Moo/CommandInterface.hs +++ b/src/Moo/CommandInterface.hs @@ -13,7 +13,6 @@ import Moo.Core import System.Console.GetOpt - -- |The available commands; used to dispatch from the command line and -- used to generate usage output. -- |The available commands; used to dispatch from the command line and @@ -83,47 +82,39 @@ findCommand :: String -> Maybe Command findCommand name = listToMaybe [ c | c <- commands, _cName c == name ] - commandOptions :: [ OptDescr (CommandOptions -> IO CommandOptions) ] commandOptions = [ optionConfigFile , optionTest , optionNoAsk ] - optionConfigFile :: OptDescr (CommandOptions -> IO CommandOptions) optionConfigFile = Option "c" ["config-file"] (ReqArg (\arg opt -> return opt { _configFilePath = Just arg }) "FILE") "Specify location of configuration file" - optionTest :: OptDescr (CommandOptions -> IO CommandOptions) optionTest = Option "t" ["test"] (NoArg (\opt -> return opt { _test = True })) "Perform the action then rollback when finished" - optionNoAsk :: OptDescr (CommandOptions -> IO CommandOptions) optionNoAsk = Option "n" ["no-ask"] (NoArg (\opt -> return opt { _noAsk = True })) "Do not interactively ask any questions, just do it" - getCommandArgs :: [String] -> IO ( CommandOptions, [String] ) getCommandArgs args = do let (actions, required, _) = getOpt RequireOrder commandOptions args opts <- foldl (>>=) defaultOptions actions return ( opts, required ) - defaultOptions :: IO CommandOptions defaultOptions = return $ CommandOptions Nothing False False - commandOptionUsage :: String commandOptionUsage = usageInfo "Options:" commandOptions - usageString :: Command -> String usageString command = diff --git a/src/Moo/CommandUtils.hs b/src/Moo/CommandUtils.hs --- a/src/Moo/CommandUtils.hs +++ b/src/Moo/CommandUtils.hs @@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} - module Moo.CommandUtils ( apply , confirmCreation , interactiveAskDeps , lookupMigration , revert - , withConnection + , withBackend + , makeBackend ) where import Control.Exception ( bracket ) @@ -14,18 +14,13 @@ import Control.Monad.Reader ( asks ) import Control.Monad.Trans ( liftIO ) import Data.List ( intercalate, sortBy ) -import Data.Maybe ( fromJust, isNothing, isJust ) +import Data.Maybe ( fromJust, isJust ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( stdout, hFlush, hGetBuffering , hSetBuffering, stdin, BufferMode(..) ) -import Database.HDBC ( IConnection, disconnect ) - import Database.Schema.Migrations ( migrationsToApply, migrationsToRevert ) -import Database.Schema.Migrations.Backend ( Backend - , applyMigration - , revertMigration - ) +import Database.Schema.Migrations.Backend (Backend(..)) import Database.Schema.Migrations.Migration ( Migration(..) ) import Database.Schema.Migrations.Store ( StoreData , storeLookup @@ -33,9 +28,7 @@ ) import Moo.Core - -apply :: (IConnection b, Backend b IO) - => Migration -> StoreData -> b -> Bool -> IO [Migration] +apply :: Migration -> StoreData -> Backend -> Bool -> IO [Migration] apply m storeData backend complain = do -- Get the list of migrations to apply toApply <- migrationsToApply storeData backend m @@ -57,9 +50,7 @@ applyMigration conn it putStrLn "done." - -revert :: (IConnection b, Backend b IO) - => Migration -> StoreData -> b -> IO [Migration] +revert :: Migration -> StoreData -> Backend -> IO [Migration] revert m storeData backend = do -- Get the list of migrations to revert toRevert <- liftIO $ migrationsToRevert storeData backend m @@ -90,37 +81,26 @@ exitWith (ExitFailure 1) Just m' -> return m' - -- Given a database type string and a database connection string, -- return a database connection or raise an error if the database -- connection cannot be established, or if the database type is not -- supported. -makeConnection :: String -> DbConnDescriptor -> IO AnyIConnection -makeConnection dbType (DbConnDescriptor connStr) = +makeBackend :: String -> DbConnDescriptor -> IO Backend +makeBackend dbType (DbConnDescriptor connStr) = case lookup dbType databaseTypes of Nothing -> error $ "Unsupported database type " ++ show dbType ++ " (supported types: " ++ intercalate "," (map fst databaseTypes) ++ ")" - Just mkConnection -> mkConnection connStr - + Just mkBackend -> mkBackend connStr -- Given an action that needs a database connection, connect to the -- database using the application configuration and invoke the action -- with the connection. Return its result. -withConnection :: (AnyIConnection -> IO a) -> AppT a -withConnection act = do - mDbPath <- asks _appDatabaseConnStr - when (isNothing mDbPath) $ error $ "Error: Database connection string not \ - \specified, please set " ++ envDatabaseName - mDbType <- asks _appDatabaseType - when (isNothing mDbType) $ - error $ "Error: Database type not specified, " ++ - "please set " ++ envDatabaseType ++ - " (supported types: " ++ - intercalate "," (map fst databaseTypes) ++ ")" - liftIO $ bracket (makeConnection (fromJust mDbType) (fromJust mDbPath)) - (\(AnyIConnection conn) -> disconnect conn) act - +withBackend :: (Backend -> IO a) -> AppT a +withBackend act = do + dbPath <- asks _appDatabaseConnStr + dbType <- asks _appDatabaseType + liftIO $ bracket (makeBackend dbType dbPath) disconnectBackend act -- Given a migration name and selected dependencies, get the user's -- confirmation that a migration should be created. @@ -135,7 +115,6 @@ , ('n', (False, Nothing)) ] - -- Prompt the user for a choice, given a prompt and a list of possible -- choices. Let the user get help for the available choices, and loop -- until the user makes a valid choice. @@ -157,7 +136,6 @@ helpChar = if hasHelp choiceMap then "h" else "" choiceMapWithHelp = choiceMap ++ [('h', (undefined, Just "this help"))] - -- Given a PromptChoices, build a multi-line help string for those -- choices using the description information in the choice list. mkPromptHelp :: PromptChoices a -> String @@ -165,18 +143,15 @@ intercalate "" [ [c] ++ ": " ++ fromJust msg ++ "\n" | (c, (_, msg)) <- choices, isJust msg ] - -- Does the specified prompt choice list have any help messages in it? hasHelp :: PromptChoices a -> Bool hasHelp = (> 0) . length . filter hasMsg where hasMsg (_, (_, m)) = isJust m - -- A general type for a set of choices that the user can make at a -- prompt. type PromptChoices a = [(Char, (a, Maybe String))] - -- Get an input character in non-buffered mode, then restore the -- original buffering setting. unbufferedGetChar :: IO Char @@ -187,13 +162,11 @@ hSetBuffering stdin bufferingMode return c - -- The types for choices the user can make when being prompted for -- dependencies. data AskDepsChoice = Yes | No | View | Done | Quit deriving (Eq) - -- Interactively ask the user about which dependencies should be used -- when creating a new migration. interactiveAskDeps :: StoreData -> IO [String] @@ -205,7 +178,6 @@ where compareTimestamps m1 m2 = compare (mTimestamp m2) (mTimestamp m1) - -- Recursive function to prompt the user for dependencies and let the -- user view information about potential dependencies. Returns a list -- of migration names which were selected. @@ -236,7 +208,6 @@ putStrLn "cancelled." exitWith (ExitFailure 1) Done -> return [] - -- The choices the user can make when being prompted for dependencies. askDepsChoices :: PromptChoices AskDepsChoice diff --git a/src/Moo/Core.hs b/src/Moo/Core.hs --- a/src/Moo/Core.hs +++ b/src/Moo/Core.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ExistentialQuantification #-} - module Moo.Core where import Control.Applicative ((<$>), (<*>)) @@ -7,67 +6,73 @@ import qualified Data.Configurator as C import Data.Configurator.Types (Config) import qualified Data.Text as T -import Database.HDBC (IConnection) import Database.HDBC.PostgreSQL (connectPostgreSQL) import Database.HDBC.Sqlite3 (connectSqlite3) +import System.Environment (getEnvironment) import Database.Schema.Migrations () -import Database.Schema.Migrations.Backend.HDBC () -import Database.Schema.Migrations.Filesystem (FilesystemStore) -import Database.Schema.Migrations.Store (StoreData) - +import Database.Schema.Migrations.Store (MigrationStore, StoreData) +import Database.Schema.Migrations.Backend +import Database.Schema.Migrations.Backend.HDBC -- |The monad in which the application runs. type AppT a = ReaderT AppState IO a - -- |The type of actions that are invoked to handle specific commands type CommandHandler = StoreData -> AppT () - -- |Application state which can be accessed by any command handler. data AppState = AppState { _appOptions :: CommandOptions , _appCommand :: Command , _appRequiredArgs :: [String] , _appOptionalArgs :: [String] - , _appStore :: FilesystemStore - , _appDatabaseConnStr :: Maybe DbConnDescriptor - , _appDatabaseType :: Maybe String + , _appStore :: MigrationStore + , _appDatabaseConnStr :: DbConnDescriptor + , _appDatabaseType :: String , _appStoreData :: StoreData } type ShellEnvironment = [(String, String)] data Configuration = Configuration - { _connectionString :: Maybe String - , _databaseType :: Maybe String - , _migrationStorePath :: Maybe FilePath + { _connectionString :: String + , _databaseType :: String + , _migrationStorePath :: FilePath } -fromShellEnvironment :: ShellEnvironment -> Configuration -fromShellEnvironment env = Configuration connectionString - databaseType - migrationStorePath +loadConfiguration :: Maybe FilePath -> IO (Either String Configuration) +loadConfiguration pth = do + mCfg <- case pth of + Nothing -> fromShellEnvironment <$> getEnvironment + Just path -> fromConfigurator =<< C.load [C.Required path] + + case mCfg of + Nothing -> do + case pth of + Nothing -> return $ Left "Missing required environment variables" + Just path -> return $ Left $ "Could not load configuration from " ++ path + Just cfg -> return $ Right cfg + +fromShellEnvironment :: ShellEnvironment -> Maybe Configuration +fromShellEnvironment env = Configuration <$> connectionString + <*> databaseType + <*> migrationStorePath where connectionString = envLookup envDatabaseName databaseType = envLookup envDatabaseType migrationStorePath = envLookup envStoreName envLookup = (\evar -> lookup evar env) -fromConfigurator :: Config -> IO Configuration -fromConfigurator conf = Configuration <$> connectionString - <*> databaseType - <*> migrationStorePath - where - connectionString = configLookup envDatabaseName - databaseType = configLookup envDatabaseType - migrationStorePath = configLookup envStoreName - configLookup = C.lookup conf . T.pack - --- |Type wrapper for IConnection instances so the makeConnection --- function can return any type of connection. -data AnyIConnection = forall c. (IConnection c) => AnyIConnection c +fromConfigurator :: Config -> IO (Maybe Configuration) +fromConfigurator conf = do + let configLookup = C.lookup conf . T.pack + connectionString <- configLookup envDatabaseName + databaseType <- configLookup envDatabaseType + migrationStorePath <- configLookup envStoreName + return $ Configuration <$> connectionString + <*> databaseType + <*> migrationStorePath -- |CommandOptions are those options that can be specified at the command -- prompt to modify the behavior of a command. @@ -76,7 +81,6 @@ , _noAsk :: Bool } - -- |A command has a name, a number of required arguments' labels, a -- number of optional arguments' labels, and an action to invoke. data Command = Command { _cName :: String @@ -87,22 +91,19 @@ , _cHandler :: CommandHandler } - -- |ConfigOptions are those options read from configuration file data ConfigData = ConfigData { _dbTypeStr :: String , _dbConnStr :: String , _fileStorePath :: String } - newtype DbConnDescriptor = DbConnDescriptor String - -- |The values of DBM_DATABASE_TYPE and their corresponding connection -- factory functions. -databaseTypes :: [(String, String -> IO AnyIConnection)] -databaseTypes = [ ("postgresql", fmap AnyIConnection . connectPostgreSQL) - , ("sqlite3", fmap AnyIConnection . connectSqlite3) +databaseTypes :: [(String, String -> IO Backend)] +databaseTypes = [ ("postgresql", fmap hdbcBackend . connectPostgreSQL) + , ("sqlite3", fmap hdbcBackend . connectSqlite3) ] envDatabaseType :: String diff --git a/src/Moo/Main.hs b/src/Moo/Main.hs --- a/src/Moo/Main.hs +++ b/src/Moo/Main.hs @@ -8,16 +8,14 @@ ) 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.Filesystem (filesystemStore, FilesystemStoreSettings(..)) import Database.Schema.Migrations.Store import Moo.CommandInterface import Moo.Core @@ -45,7 +43,8 @@ usageSpecific :: Command -> IO a usageSpecific command = do - putStrLn $ "Usage: initstore-fs " ++ usageString command + pn <- getProgName + putStrLn $ "Usage: " ++ pn ++ " " ++ usageString command exitWith (ExitFailure 1) procArgs :: Args -> IO (Command, CommandOptions, [String]) @@ -64,14 +63,10 @@ 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 } + let dbConnStr = _connectionString conf + dbType = _databaseType conf + storePathStr = _migrationStorePath conf + store = filesystemStore $ FSStore { storePath = storePathStr } if length required < length ( _cRequired command) then usageSpecific command else @@ -86,9 +81,9 @@ , _appCommand = command , _appRequiredArgs = required , _appOptionalArgs = ["" :: String] - , _appDatabaseConnStr = liftM DbConnDescriptor mDbConnStr - , _appDatabaseType = mDbType - , _appStore = FSStore storePathStr + , _appDatabaseConnStr = DbConnDescriptor dbConnStr + , _appDatabaseType = dbType + , _appStore = store , _appStoreData = storeData } runReaderT (_cHandler command storeData) st `catchSql` reportSqlError diff --git a/test/BackendTest.hs b/test/BackendTest.hs --- a/test/BackendTest.hs +++ b/test/BackendTest.hs @@ -3,7 +3,7 @@ import Test.HUnit import Control.Monad ( forM_ ) -import Database.Schema.Migrations.Backend.HDBC () +import Database.Schema.Migrations.Backend.HDBC import Database.Schema.Migrations.Migration ( Migration(..), newMigration ) import Database.Schema.Migrations.Backend ( Backend(..) ) @@ -26,19 +26,20 @@ bootstrapTest :: (IConnection a) => a -> IO () bootstrapTest conn = do - bs <- getBootstrapMigration conn - applyMigration conn bs + let backend = hdbcBackend conn + bs <- getBootstrapMigration backend + applyMigration backend bs assertEqual "installed_migrations table exists" ["installed_migrations"] =<< getTables conn - assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations conn + assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations backend isBootstrappedTrueTest :: (IConnection a) => a -> IO () isBootstrappedTrueTest conn = do - result <- isBootstrapped conn + result <- isBootstrapped $ hdbcBackend conn assertBool "Bootstrapped check" result isBootstrappedFalseTest :: (IConnection a) => a -> IO () isBootstrappedFalseTest conn = do - result <- isBootstrapped conn + result <- isBootstrapped $ hdbcBackend conn assertBool "Bootstrapped check" $ not result ignoreSqlExceptions :: IO a -> IO (Maybe a) @@ -47,97 +48,97 @@ applyMigrationSuccess :: (IConnection a) => a -> IO () applyMigrationSuccess conn = do - m1 <- newMigration "validMigration" + let backend = hdbcBackend conn - let m1' = m1 { mApply = "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int);" } + let m1 = (newMigration "validMigration") { mApply = "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int);" } -- Apply the migrations, ignore exceptions - withTransaction conn $ \conn' -> applyMigration conn' m1' + withTransaction conn $ \conn' -> applyMigration (hdbcBackend conn') m1 -- Check that none of the migrations were installed - assertEqual "Installed migrations" ["root", "validMigration"] =<< getMigrations conn + assertEqual "Installed migrations" ["root", "validMigration"] =<< getMigrations backend 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 backend = hdbcBackend conn - let m1' = m1 { mApply = "CREATE TABLE validButTemporary (a int)" } - let m2' = m2 { mApply = "INVALID SQL" } + let m1 = (newMigration "second") { mApply = "CREATE TABLE validButTemporary (a int)" } + m2 = (newMigration "third") { mApply = "INVALID SQL" } -- Apply the migrations, ignore exceptions ignoreSqlExceptions $ withTransaction conn $ \conn' -> do - applyMigration conn' m1' - applyMigration conn' m2' + let backend' = hdbcBackend conn' + applyMigration backend' m1 + applyMigration backend' m2 -- Check that none of the migrations were installed - assertEqual "Installed migrations" ["root"] =<< getMigrations conn + assertEqual "Installed migrations" ["root"] =<< getMigrations backend assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn revertMigrationFailure :: (IConnection a) => a -> IO () revertMigrationFailure conn = do - m1 <- newMigration "second" - m2 <- newMigration "third" + let backend = hdbcBackend conn - 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"} + let m1 = (newMigration "second") { mApply = "CREATE TABLE validRMF (a int)" + , mRevert = Just "DROP TABLE validRMF"} + m2 = (newMigration "third") { mApply = "SELECT * FROM validRMF" + , mRevert = Just "INVALID REVERT SQL"} - applyMigration conn m1' - applyMigration conn m2' + applyMigration backend m1 + applyMigration backend m2 - installedBeforeRevert <- getMigrations conn + installedBeforeRevert <- getMigrations backend - commit conn + commitBackend backend -- 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' + let backend' = hdbcBackend conn' + revertMigration backend' m2 + revertMigration backend' m1 -- Check that none of the migrations were reverted assertEqual "successfully roll back failed revert" installedBeforeRevert - =<< getMigrations conn + =<< getMigrations backend revertMigrationNothing :: (IConnection a) => a -> IO () revertMigrationNothing conn = do - m1 <- newMigration "second" + let backend = hdbcBackend conn - let m1' = m1 { mApply = "SELECT 1" - , mRevert = Nothing } + let m1 = (newMigration "second") { mApply = "SELECT 1" + , mRevert = Nothing } - applyMigration conn m1' + applyMigration backend m1 - installedAfterApply <- getMigrations conn + installedAfterApply <- getMigrations backend 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' + revertMigration backend m1 - installed <- getMigrations conn + installed <- getMigrations backend 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 + backend = hdbcBackend conn - let m1' = m1 { mApply = "CREATE TABLE the_test_table (a int)" - , mRevert = Just "DROP TABLE the_test_table" } + let m1 = (newMigration name) { mApply = "CREATE TABLE the_test_table (a int)" + , mRevert = Just "DROP TABLE the_test_table" } - applyMigration conn m1' + applyMigration backend m1 - installedAfterApply <- getMigrations conn + installedAfterApply <- getMigrations backend 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' + revertMigration backend m1 - installed <- getMigrations conn + installed <- getMigrations backend assertBool "Check that the migration was reverted" $ not $ name `elem` installed diff --git a/test/FilesystemParseTest.hs b/test/FilesystemParseTest.hs --- a/test/FilesystemParseTest.hs +++ b/test/FilesystemParseTest.hs @@ -11,7 +11,7 @@ import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Filesystem - ( FilesystemStore(..) + ( FilesystemStoreSettings(..) , migrationFromFile ) @@ -29,7 +29,7 @@ valid_full :: Migration valid_full = Migration { - mTimestamp = ts + mTimestamp = Just ts , mId = "valid_full" , mDesc = Just "A valid full migration." , mDeps = ["another_migration"] @@ -39,7 +39,7 @@ valid_full_comments :: Migration valid_full_comments = Migration { - mTimestamp = ts + mTimestamp = Just ts , mId = "valid_full" , mDesc = Just "A valid full migration." , mDeps = ["another_migration"] @@ -49,7 +49,7 @@ valid_full_colon :: Migration valid_full_colon = Migration { - mTimestamp = ts + mTimestamp = Just ts , mId = "valid_full" , mDesc = Just "A valid full migration." , mDeps = ["another_migration"] @@ -80,13 +80,15 @@ , Right (valid_full { mId = "valid_no_desc", mDesc = Nothing })) , ("valid_no_revert" , Right (valid_full { mId = "valid_no_revert", mRevert = Nothing })) + , ("valid_no_timestamp" + , Right (valid_full { mId = "valid_no_timestamp", mTimestamp = 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\"]") + "[\"Depends\"]") , ("invalid_field_name" , Left $ "Could not parse migration " ++ (fp "invalid_field_name.txt") ++ diff --git a/test/FilesystemSerializeTest.hs b/test/FilesystemSerializeTest.hs --- a/test/FilesystemSerializeTest.hs +++ b/test/FilesystemSerializeTest.hs @@ -23,7 +23,7 @@ valid_full :: Migration valid_full = Migration { - mTimestamp = ts + mTimestamp = Just ts , mId = "valid_full" , mDesc = Just "A valid full migration." , mDeps = ["another_migration"] diff --git a/test/FilesystemTest.hs b/test/FilesystemTest.hs --- a/test/FilesystemTest.hs +++ b/test/FilesystemTest.hs @@ -15,7 +15,7 @@ getMigrationsTest :: IO Test getMigrationsTest = do - let store = FSStore { storePath = testFile "migration_parsing" } + let store = filesystemStore $ FSStore { storePath = testFile "migration_parsing" } expected = Set.fromList [ "invalid_field_name" , "invalid_missing_required_fields" , "invalid_syntax" @@ -24,6 +24,7 @@ , "valid_no_depends" , "valid_no_desc" , "valid_no_revert" + , "valid_no_timestamp" , "valid_with_comments" , "valid_with_comments2" , "valid_with_colon" diff --git a/test/MigrationsTest.hs b/test/MigrationsTest.hs --- a/test/MigrationsTest.hs +++ b/test/MigrationsTest.hs @@ -5,42 +5,40 @@ where import Test.HUnit -import Control.Monad.Identity ( runIdentity, Identity ) +import Control.Applicative ((<$>)) import qualified Data.Map as Map import Data.Time.Clock ( UTCTime ) import Database.Schema.Migrations -import Database.Schema.Migrations.Store +import Database.Schema.Migrations.Store hiding (getMigrations) 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 +testBackend :: [Migration] -> Backend +testBackend testMs = + Backend { getBootstrapMigration = undefined + , isBootstrapped = return True + , applyMigration = const undefined + , revertMigration = const undefined + , getMigrations = return $ mId <$> testMs + , commitBackend = return () + , rollbackBackend = return () + , disconnectBackend = return () + } -- |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, +type MissingMigrationTestCase = (MigrationMap, Backend, Migration, [Migration]) ts :: UTCTime ts = read "2009-04-15 10:02:06 UTC" blankMigration :: Migration -blankMigration = Migration { mTimestamp = ts +blankMigration = Migration { mTimestamp = Just ts , mId = undefined , mDesc = Nothing , mApply = "" @@ -49,11 +47,11 @@ } missingMigrationsTestcases :: [MissingMigrationTestCase] -missingMigrationsTestcases = [ (m, [], one, [one]) - , (m, [one], one, []) - , (m, [one], two, [two]) - , (m, [one, two], one, []) - , (m, [one, two], two, []) +missingMigrationsTestcases = [ (m, testBackend [], one, [one]) + , (m, testBackend [one], one, []) + , (m, testBackend [one], two, [two]) + , (m, testBackend [one, two], one, []) + , (m, testBackend [one, two], two, []) ] where one = blankMigration { mId = "one" } @@ -64,9 +62,10 @@ 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 + result = migrationsToApply storeData backend theMigration + in "a test" ~: do + actual <- result + return $ expected == actual migrationsToApplyTests :: [Test] migrationsToApplyTests = map mkTest missingMigrationsTestcases