diff --git a/MOO.TXT b/MOO.TXT --- a/MOO.TXT +++ b/MOO.TXT @@ -6,7 +6,8 @@ "moo", is responsible for creating, installing, and reverting migrations in your database backend. -At present, PostgreSQL and Sqlite3 are the only supported database backends. +At present, PostgreSQL and Sqlite3 are the only supported database +backends. The moo tool works by creating migration files in a specific location, called a migration store, on your filesystem. This directory is where @@ -126,7 +127,19 @@ DBM_DATABASE_TYPE = "sqlite3" DBM_DATABASE = "/path/to/database.db" DBM_MIGRATION_STORE = "/path/to/migration/store" + DBM_LINEAR_MIGRATIONS = on/off (or true/false; defaults to off) + DBM_TIMESTAMP_FILENAMES = on/off (or true/false; defaults to off) +Alternatively, you may save your settings to "moo.cfg" file in the current +directory (probably a project root) and moo will load it automatically, if +present. Specifying --config-file disables this behavior. + +If you use a config file (either the default one or the one specified with +--config-file option) but the environment variables are set, they will +override settings from the file. You may use this to have project settings +specified in a file and use environment to specify user-local configuration +options. + Migration file format --------------------- @@ -177,7 +190,8 @@ Environment ----------- -Moo depends on these environment variables: +Moo depends on these environment variables / configuration file +settings: DBM_DATABASE_TYPE @@ -211,15 +225,25 @@ schema. Initially, you'll probably set this to an extant (but empty) directory. moo will not create it for you. + DBM_LINEAR_MIGRATIONS + + If set to true/on, the linear migrations feature will be enabled. + Defaults to off. See 'Linear migrations' section for more details. + + DBM_TIMESTAMP_FILENAMES + + If set to true/on, the migration filename for new migrations will + have a timestamp embedded in it. + Commands -------- new : create a new migration with the given name and save it in the migration store. This command will prompt you for - dependencies on other migrations and ask for confirmation before - creating the migration in the store. If you use the --no-ask - flag, the migration will be created immediately with no - dependencies. + dependencies on other migrations (if the 'linear migrations' + feature is disabled) and ask for confirmation before creating the + migration in the store. If you use the --no-ask flag, the migration + will be created immediately with no dependencies. apply : apply the specified migration (and its dependencies) to the database. This operation will be performed @@ -257,3 +281,14 @@ 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. + +Linear migrations +----------------- + +If you know that every migration needs to depend on all previous ones, +consider enabling this feature. When enabled, 'moo new' will automatically +select smallest subset of existing migrations that will make the new one +indirectly depend on every other already in the store. This in turn makes +the store linear-ish (in terms of order of execution) and helps managing the +migrations by always depending on previous work. Also, this may easily be used +to see how the database changed in time. diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 0.9.1 +Version: 1.0 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -108,11 +108,14 @@ template-haskell, yaml-light >= 0.1, bytestring >= 0.9, + MissingH, HDBC >= 2.2.1, HDBC-postgresql, HDBC-sqlite3, HUnit >= 1.2, - process >= 1.1 + process >= 1.1, + configurator >= 0.2, + text >= 0.11 other-modules: BackendTest @@ -126,6 +129,9 @@ MigrationsTest StoreTest TestDriver + InMemoryStore + LinearMigrationsTest + ConfigurationTest if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields 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 @@ -29,7 +29,7 @@ import Database.Schema.Migrations.Migration ( Migration(..) - , newMigration + , emptyMigration ) import Database.Schema.Migrations.Filesystem.Serialize import Database.Schema.Migrations.Store @@ -98,7 +98,7 @@ case length missing of 0 -> do - let newM = newMigration name + let newM = emptyMigration name case migrationFromFields newM fields of Nothing -> throwFS $ "Error in " ++ (show path) ++ ": unrecognized field found" Just m -> return 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,7 @@ module Database.Schema.Migrations.Migration ( Migration(..) , newMigration + , emptyMigration ) where @@ -22,12 +23,19 @@ depsOf = mDeps depId = mId -newMigration :: String -> Migration -newMigration theId = +emptyMigration :: String -> Migration +emptyMigration name = Migration { mTimestamp = Nothing - , mId = theId - , mApply = "(Apply SQL here.)" + , mId = name + , mApply = "" , mRevert = Nothing - , mDesc = Just "(Describe migration here.)" + , mDesc = Nothing , mDeps = [] } + +newMigration :: String -> Migration +newMigration theId = + (emptyMigration theId) + { mApply = "(Apply SQL here.)" + , mDesc = Just "(Describe migration here.)" + } 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 @@ -19,6 +19,7 @@ , depGraphFromMapping , validateMigrationMap , validateSingleMigration + , leafMigrations ) where @@ -26,6 +27,7 @@ import Control.Monad ( mzero ) import Control.Applicative ( (<$>) ) import qualified Data.Map as Map +import Data.Graph.Inductive.Graph ( labNodes, indeg ) import Database.Schema.Migrations.Migration ( Migration(..) @@ -148,3 +150,9 @@ -- won't want to use this directly; use 'loadMigrations' instead. depGraphFromMapping :: MigrationMap -> Either String (DependencyGraph Migration) depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping + +-- |Finds migrations that no other migration depends on (effectively finds all +-- vertices with in-degree equal to zero). +leafMigrations :: StoreData -> [String] +leafMigrations s = [l | (n, l) <- labNodes g, indeg g n == 0] + where g = depGraph $ storeDataGraph s diff --git a/src/Moo/CommandHandlers.hs b/src/Moo/CommandHandlers.hs --- a/src/Moo/CommandHandlers.hs +++ b/src/Moo/CommandHandlers.hs @@ -20,25 +20,31 @@ newCommand :: CommandHandler newCommand storeData = do - required <- asks _appRequiredArgs - store <- asks _appStore - let [migrationId] = required + required <- asks _appRequiredArgs + store <- asks _appStore + linear <- asks _appLinearMigrations + timestamp <- asks _appTimestampFilenames + timeString <- (++"_") <$> liftIO getCurrentTimestamp + + let [migrationId] = if timestamp + then fmap (timeString++) required + else required noAsk <- _noAsk <$> asks _appOptions liftIO $ do fullPath <- fullMigrationName store migrationId - when (isJust $ storeLookup storeData migrationId) $ do putStrLn $ "Migration " ++ (show fullPath) ++ " already exists" exitWith (ExitFailure 1) - -- Default behavior: ask for dependencies - deps <- if noAsk then (return []) else - do - putStrLn $ "Selecting dependencies for new \ - \migration: " ++ migrationId - interactiveAskDeps storeData + -- Default behavior: ask for dependencies if linear mode is disabled + deps <- if linear then (return $ leafMigrations storeData) else + if noAsk then (return []) else + do + putStrLn $ "Selecting dependencies for new \ + \migration: " ++ migrationId + interactiveAskDeps storeData result <- if noAsk then (return True) else (confirmCreation migrationId deps) @@ -47,14 +53,14 @@ True -> do now <- Clock.getCurrentTime status <- createNewMigration store $ (newMigration migrationId) { mDeps = deps - , mTimestamp = Just now - } + , mTimestamp = Just now + } case status of - Left e -> putStrLn e >> (exitWith (ExitFailure 1)) - Right _ -> putStrLn $ "Migration created successfully: " ++ - show fullPath + Left e -> putStrLn e >> (exitWith (ExitFailure 1)) + Right _ -> putStrLn $ "Migration created successfully: " ++ + show fullPath False -> do - putStrLn "Migration creation cancelled." + putStrLn "Migration creation cancelled." upgradeCommand :: CommandHandler upgradeCommand storeData = do diff --git a/src/Moo/CommandUtils.hs b/src/Moo/CommandUtils.hs --- a/src/Moo/CommandUtils.hs +++ b/src/Moo/CommandUtils.hs @@ -7,13 +7,15 @@ , revert , withBackend , makeBackend + , getCurrentTimestamp ) where import Control.Exception ( bracket ) import Control.Monad ( when, forM_, unless ) import Control.Monad.Reader ( asks ) import Control.Monad.Trans ( liftIO ) -import Data.List ( intercalate, sortBy ) +import Data.List ( intercalate, sortBy, isPrefixOf ) +import Data.Time.Clock (getCurrentTime) import Data.Maybe ( fromJust, isJust ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( stdout, hFlush, hGetBuffering @@ -28,6 +30,10 @@ ) import Moo.Core +getCurrentTimestamp :: IO String +getCurrentTimestamp = + replace ":" "-" . replace " " "_" . take 19 . show <$> getCurrentTime + apply :: Migration -> StoreData -> Backend -> Bool -> IO [Migration] apply m storeData backend complain = do -- Get the list of migrations to apply @@ -217,3 +223,38 @@ , ('d', (Done, Just "done, do not ask me about more dependencies")) , ('q', (Quit, Just "cancel this operation and quit")) ] + +-- The following code is vendored from MissingH Data.List.Utils: + +{- | Similar to Data.List.span, but performs the test on the entire remaining +list instead of just one element. + +@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ +-} +spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) + +spanList _ [] = ([],[]) +spanList func list@(x:xs) = + if func list + then (x:ys,zs) + else ([],list) + where (ys,zs) = spanList func xs + +{- | Similar to Data.List.break, but performs the test on the entire remaining +list instead of just one element. +-} +breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) +breakList func = spanList (not . func) + +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new = intercalate new . split old + +split :: Eq a => [a] -> [a] -> [[a]] +split _ [] = [] +split delim str = + let (firstline, remainder) = breakList (isPrefixOf delim) str + in firstline : case remainder of + [] -> [] + x -> if x == delim + then [[]] + else split delim (drop (length delim) x) diff --git a/src/Moo/Core.hs b/src/Moo/Core.hs --- a/src/Moo/Core.hs +++ b/src/Moo/Core.hs @@ -1,15 +1,31 @@ {-# LANGUAGE ExistentialQuantification #-} -module Moo.Core where +module Moo.Core + ( AppT + , CommandHandler + , CommandOptions (..) + , Command (..) + , AppState (..) + , Configuration (..) + , DbConnDescriptor (..) + , databaseTypes + , envDatabaseName + , envDatabaseType + , envLinearMigrations + , envStoreName + , loadConfiguration) where import Control.Applicative ((<$>), (<*>)) import Control.Monad.Reader (ReaderT) import qualified Data.Configurator as C -import Data.Configurator.Types (Config) +import Data.Configurator.Types (Config, Configured) import qualified Data.Text as T +import Data.Char (toLower) import Database.HDBC.PostgreSQL (connectPostgreSQL) import Database.HDBC.Sqlite3 (connectSqlite3) import System.Environment (getEnvironment) +import Data.Maybe (isJust, fromMaybe) + import Database.Schema.Migrations () import Database.Schema.Migrations.Store (MigrationStore, StoreData) import Database.Schema.Migrations.Backend @@ -22,14 +38,16 @@ 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 :: MigrationStore - , _appDatabaseConnStr :: DbConnDescriptor - , _appDatabaseType :: String - , _appStoreData :: StoreData +data AppState = AppState { _appOptions :: CommandOptions + , _appCommand :: Command + , _appRequiredArgs :: [String] + , _appOptionalArgs :: [String] + , _appStore :: MigrationStore + , _appDatabaseConnStr :: DbConnDescriptor + , _appDatabaseType :: String + , _appStoreData :: StoreData + , _appLinearMigrations :: Bool + , _appTimestampFilenames :: Bool } type ShellEnvironment = [(String, String)] @@ -38,42 +56,106 @@ { _connectionString :: String , _databaseType :: String , _migrationStorePath :: FilePath - } + , _linearMigrations :: Bool + , _timestampFilenames :: Bool + } deriving Show -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] +-- |Intermediate type used during config loading. +data LoadConfig = LoadConfig + { _lcConnectionString :: Maybe String + , _lcDatabaseType :: Maybe String + , _lcMigrationStorePath :: Maybe FilePath + , _lcLinearMigrations :: Maybe Bool + , _lcTimestampFilenames :: Maybe Bool + } deriving Show - 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 +defConfigFile :: String +defConfigFile = "moo.cfg" -fromShellEnvironment :: ShellEnvironment -> Maybe Configuration -fromShellEnvironment env = Configuration <$> connectionString - <*> databaseType - <*> migrationStorePath +newLoadConfig :: LoadConfig +newLoadConfig = LoadConfig Nothing Nothing Nothing Nothing Nothing + +isValidConfig :: LoadConfig -> Bool +isValidConfig (LoadConfig a b c _ _) = all isJust [a, b, c] + +loadConfigToConfig :: LoadConfig -> Configuration +loadConfigToConfig (LoadConfig (Just cs) (Just dt) (Just msp) lm ts) = + Configuration cs dt msp + (fromMaybe False lm) + (fromMaybe False ts) +loadConfigToConfig _ = error "LoadConfig is invalid!" + +-- |Setters for fields of 'LoadConfig'. +lcConnectionString, lcDatabaseType, lcMigrationStorePath + :: LoadConfig -> Maybe String -> LoadConfig +lcConnectionString c v = c { _lcConnectionString = v } +lcDatabaseType c v = c { _lcDatabaseType = v } +lcMigrationStorePath c v = c { _lcMigrationStorePath = v } + +lcLinearMigrations :: LoadConfig -> Maybe Bool -> LoadConfig +lcLinearMigrations c v = c { _lcLinearMigrations = v } +lcTimestampFilenames c v = c { _lcTimestampFilenames = v } + + +-- | @f .= v@ invokes f only if v is 'Just' +(.=) :: (Monad m) => (a -> Maybe b -> a) -> m (Maybe b) -> m (a -> a) +(.=) f v' = do + v <- v' + return $ case v of + Just _ -> flip f v + _ -> id + +-- |It's just @flip '<*>'@ +(&) :: (Applicative m) => m a -> m (a -> b) -> m b +(&) = flip (<*>) + +infixr 3 .= +infixl 2 & + +applyEnvironment :: ShellEnvironment -> LoadConfig -> IO LoadConfig +applyEnvironment env lc = + return lc & lcConnectionString .= f envDatabaseName + & lcDatabaseType .= f envDatabaseType + & lcMigrationStorePath .= f envStoreName + & lcLinearMigrations .= readFlag <$> f envLinearMigrations + where f n = return $ lookup n env + +applyConfigFile :: Config -> LoadConfig -> IO LoadConfig +applyConfigFile cfg lc = + return lc & lcConnectionString .= f envDatabaseName + & lcDatabaseType .= f envDatabaseType + & lcMigrationStorePath .= f envStoreName + & lcLinearMigrations .= f envLinearMigrations + & lcTimestampFilenames .= f envTimestampFilenames where - connectionString = envLookup envDatabaseName - databaseType = envLookup envDatabaseType - migrationStorePath = envLookup envStoreName - envLookup = (\evar -> lookup evar env) + f :: Configured a => String -> IO (Maybe a) + f = C.lookup cfg . T.pack -fromConfigurator :: Config -> IO (Maybe Configuration) -fromConfigurator conf = do - let configLookup = C.lookup conf . T.pack - connectionString <- configLookup envDatabaseName - databaseType <- configLookup envDatabaseType - migrationStorePath <- configLookup envStoreName +-- |Loads config file (falling back to default one if not specified) and then +-- overrides configuration with an environment. +loadConfiguration :: Maybe FilePath -> IO (Either String Configuration) +loadConfiguration pth = do + file <- maybe (C.load [C.Optional defConfigFile]) + (\p -> C.load [C.Required p]) pth + env <- getEnvironment + cfg <- applyConfigFile file newLoadConfig >>= applyEnvironment env - return $ Configuration <$> connectionString - <*> databaseType - <*> migrationStorePath + if isValidConfig cfg + then return $ Right $ loadConfigToConfig cfg + else return $ Left "Configuration is invalid, check if everything is set." +-- |Converts @Just "on"@ and @Just "true"@ (case insensitive) to @True@, +-- anything else to @False@. +readFlag :: Maybe String -> Maybe Bool +readFlag Nothing = Nothing +readFlag (Just v) = go $ map toLower v + where + go "on" = Just True + go "true" = Just True + go "off" = Just False + go "false" = Just False + go _ = Nothing + -- |CommandOptions are those options that can be specified at the command -- prompt to modify the behavior of a command. data CommandOptions = CommandOptions { _configFilePath :: Maybe String @@ -91,12 +173,6 @@ , _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 @@ -114,3 +190,9 @@ envStoreName :: String envStoreName = "DBM_MIGRATION_STORE" + +envLinearMigrations :: String +envLinearMigrations = "DBM_LINEAR_MIGRATIONS" + +envTimestampFilenames :: String +envTimestampFilenames = "DBM_TIMESTAMP_FILENAMES" diff --git a/src/Moo/Main.hs b/src/Moo/Main.hs --- a/src/Moo/Main.hs +++ b/src/Moo/Main.hs @@ -32,6 +32,7 @@ putStrLn $ " " ++ envDatabaseType ++ ": database type, one of " ++ intercalate "," (map fst databaseTypes) putStrLn $ " " ++ envStoreName ++ ": path to migration store" + putStrLn $ " " ++ envLinearMigrations ++ ": whether to use linear migrations (defaults to False)" putStrLn "Commands:" forM_ commands $ \command -> do putStrLn $ " " ++ usageString command @@ -67,6 +68,7 @@ dbType = _databaseType conf storePathStr = _migrationStorePath conf store = filesystemStore $ FSStore { storePath = storePathStr } + linear = _linearMigrations conf if length required < length ( _cRequired command) then usageSpecific command else @@ -85,6 +87,8 @@ , _appDatabaseType = dbType , _appStore = store , _appStoreData = storeData + , _appLinearMigrations = linear + , _appTimestampFilenames = _timestampFilenames conf } runReaderT (_cHandler command storeData) st `catchSql` reportSqlError diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -3,12 +3,15 @@ ( TestDependable(..) , repoRoot , testFile + , satisfies + , (.&&.) ) where import CommonTH import System.FilePath ( () ) import Language.Haskell.TH.Syntax (lift) +import Test.HUnit import Database.Schema.Migrations.Dependencies ( Dependable(..) ) @@ -26,3 +29,14 @@ , tdDeps :: [String] } deriving (Show, Eq, Ord) + + +satisfies :: String -> a -> (a -> Bool) -> IO Test +satisfies m v f = return $ TestCase $ assertBool m (f v) + +(.&&.) :: Test -> Test -> Test +(TestList xs) .&&. (TestList ys) = TestList (xs ++ ys) +(TestList xs) .&&. y = TestList (xs ++ [y]) +x .&&. (TestList ys) = TestList (x:ys) +a .&&. b = TestList [a, b] +infixl 0 .&&. diff --git a/test/ConfigurationTest.hs b/test/ConfigurationTest.hs new file mode 100644 --- /dev/null +++ b/test/ConfigurationTest.hs @@ -0,0 +1,104 @@ +module ConfigurationTest (tests) where + +import Control.Exception (SomeException, try) +import Data.Either (isLeft, isRight) +import System.Directory +import System.Environment (setEnv, unsetEnv) +import Test.HUnit + +import Common +import Moo.Core + +tests :: IO [Test] +tests = sequence [prepareTestEnv >> e | e <- entries] + where entries = [ loadsConfigFile + , loadsPropertiesFromFile + , loadsDefaultConfigFile + , environmentOverridesProperties + , ifNoConfigFileIsAvailableEnvironmentIsUsed + , throwsWhenConfigFileIsInvalid + , returnsErrorWhenNotAllPropertiesAreSet + , canReadTimestampsConfig + ] + +prepareTestEnv :: IO () +prepareTestEnv = do + setCurrentDirectory $ testFile "config_loading" + unsetEnv "DBM_DATABASE_TYPE" + unsetEnv "DBM_DATABASE" + unsetEnv "DBM_MIGRATION_STORE" + unsetEnv "DBM_LINEAR_MIGRATIONS" + unsetEnv "DBM_TIMESTAMP_FILENAMES" + +canReadTimestampsConfig :: IO Test +canReadTimestampsConfig = do + Right cfg <- loadConfiguration (Just "cfg_ts.cfg") + satisfies "Timestamp not set" cfg _timestampFilenames + +loadsConfigFile :: IO Test +loadsConfigFile = do + cfg' <- loadConfiguration (Just "cfg1.cfg") + satisfies "File not loaded" cfg' isRight + +loadsPropertiesFromFile :: IO Test +loadsPropertiesFromFile = do + Right cfg <- loadConfiguration (Just "cfg1.cfg") + return + ( + _connectionString cfg ~?= "connection" .&&. + _databaseType cfg ~?= "dbtype" .&&. + _migrationStorePath cfg ~?= "store" .&&. + _linearMigrations cfg ~?= True + ) + +loadsDefaultConfigFile :: IO Test +loadsDefaultConfigFile = do + Right cfg <- loadConfiguration Nothing + return + ( + _connectionString cfg ~?= "mooconn" .&&. + _databaseType cfg ~?= "moodb" .&&. + _migrationStorePath cfg ~?= "moostore" .&&. + _linearMigrations cfg ~?= True + ) + +environmentOverridesProperties :: IO Test +environmentOverridesProperties = do + setEnv "DBM_DATABASE_TYPE" "envdb" + setEnv "DBM_DATABASE" "envconn" + setEnv "DBM_MIGRATION_STORE" "envstore" + setEnv "DBM_LINEAR_MIGRATIONS" "off" + Right cfg <- loadConfiguration (Just "cfg1.cfg") + return + ( + _connectionString cfg ~?= "envconn" .&&. + _databaseType cfg ~?= "envdb" .&&. + _migrationStorePath cfg ~?= "envstore" .&&. + _linearMigrations cfg ~?= False + ) + +ifNoConfigFileIsAvailableEnvironmentIsUsed :: IO Test +ifNoConfigFileIsAvailableEnvironmentIsUsed = do + setCurrentDirectory $ testFile "" + setEnv "DBM_DATABASE_TYPE" "envdb" + setEnv "DBM_DATABASE" "envconn" + setEnv "DBM_MIGRATION_STORE" "envstore" + setEnv "DBM_LINEAR_MIGRATIONS" "off" + Right cfg <- loadConfiguration Nothing + return + ( + _connectionString cfg ~?= "envconn" .&&. + _databaseType cfg ~?= "envdb" .&&. + _migrationStorePath cfg ~?= "envstore" .&&. + _linearMigrations cfg ~?= False + ) + +returnsErrorWhenNotAllPropertiesAreSet :: IO Test +returnsErrorWhenNotAllPropertiesAreSet = do + cfg <- loadConfiguration (Just "missing.cfg") + satisfies "Should return error" cfg isLeft + +throwsWhenConfigFileIsInvalid :: IO Test +throwsWhenConfigFileIsInvalid = do + c <- try $ loadConfiguration (Just "invalid.cfg") + satisfies "Should throw" c (isLeft :: Either SomeException a -> Bool) diff --git a/test/FilesystemParseTest.hs b/test/FilesystemParseTest.hs --- a/test/FilesystemParseTest.hs +++ b/test/FilesystemParseTest.hs @@ -116,4 +116,4 @@ migrationParsingTests :: IO [Test] migrationParsingTests = - sequence $ map mkParsingTest migrationParsingTestCases + traverse mkParsingTest migrationParsingTestCases diff --git a/test/InMemoryStore.hs b/test/InMemoryStore.hs new file mode 100644 --- /dev/null +++ b/test/InMemoryStore.hs @@ -0,0 +1,32 @@ +module InMemoryStore (inMemoryStore) where + +import Control.Concurrent.MVar +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store + +type InMemoryData = [(String, Migration)] + +-- |Builds simple in-memory store that uses 'MVar' to preserve a list of +-- migrations. +inMemoryStore :: IO MigrationStore +inMemoryStore = do + store <- newMVar [] + return MigrationStore { + loadMigration = loadMigrationInMem store + , saveMigration = saveMigrationInMem store + , getMigrations = getMigrationsInMem store + , fullMigrationName = return + } + +loadMigrationInMem :: MVar InMemoryData -> String -> IO (Either String Migration) +loadMigrationInMem store migId = withMVar store $ \migrations -> do + let mig = lookup migId migrations + return $ case mig of + Just m -> Right m + _ -> Left "Migration not found" + +saveMigrationInMem :: MVar InMemoryData -> Migration -> IO () +saveMigrationInMem store m = modifyMVar_ store $ return . ((mId m, m):) + +getMigrationsInMem :: MVar InMemoryData -> IO [String] +getMigrationsInMem store = withMVar store $ return . fmap fst diff --git a/test/LinearMigrationsTest.hs b/test/LinearMigrationsTest.hs new file mode 100644 --- /dev/null +++ b/test/LinearMigrationsTest.hs @@ -0,0 +1,95 @@ +module LinearMigrationsTest (tests) where + +import InMemoryStore +import Test.HUnit + +import Common +import Control.Monad.Reader (runReaderT) +import Data.Either (isRight) +import Data.Maybe (isNothing) +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store +import Moo.CommandHandlers +import Moo.Core + +tests :: IO [Test] +tests = sequence [ addsMigration + , selectsLatestMigrationAsDep + , selectsOnlyLeavesAsDeps + , doesNotAddDependencyWhenLinearMigrationsAreDisabled + ] + +addsMigration :: IO Test +addsMigration = do + state <- prepareState "first" + mig <- addTestMigration state + satisfies "Migration not added" mig isRight + +selectsLatestMigrationAsDep :: IO Test +selectsLatestMigrationAsDep = do + state1 <- prepareState "first" + _ <- addTestMigration state1 + state2 <- prepareStateWith state1 "second" + Right mig <- addTestMigration state2 + return $ ["first"] ~=? mDeps mig + +selectsOnlyLeavesAsDeps :: IO Test +selectsOnlyLeavesAsDeps = do + state1 <- prepareNormalState "first" + addTestMigrationWithDeps state1 [] + state2 <- prepareStateWith state1 "second" + addTestMigrationWithDeps state2 ["first"] + state3 <- prepareStateWith state2 "third" + addTestMigrationWithDeps state3 ["first"] + state4' <- prepareStateWith state3 "fourth" + let state4 = state4' { _appLinearMigrations = True } + Right mig <- addTestMigration state4 + return $ ["second", "third"] ~=? mDeps mig + +doesNotAddDependencyWhenLinearMigrationsAreDisabled :: IO Test +doesNotAddDependencyWhenLinearMigrationsAreDisabled = do + state1 <- prepareNormalState "first" + _ <- addTestMigration state1 + state2 <- prepareStateWith state1 "second" + Right mig <- addTestMigration state2 + satisfies "Dependencies should be empty" (mDeps mig) null + +addTestMigration :: AppState -> IO (Either String Migration) +addTestMigration state = do + let store = _appStore state + [migrationId] = _appRequiredArgs state + runReaderT (newCommand $ _appStoreData state) state + loadMigration store migrationId + +addTestMigrationWithDeps :: AppState -> [String] -> IO () +addTestMigrationWithDeps state deps = do + let store = _appStore state + let [migrationId] = _appRequiredArgs state + saveMigration store (newMigration migrationId) { mDeps = deps } + +prepareState :: String -> IO AppState +prepareState m = do + store <- inMemoryStore + Right storeData <- loadMigrations store + return AppState { + _appOptions = CommandOptions Nothing False True + , _appCommand = undefined -- Not used by newCommand + , _appRequiredArgs = [m] + , _appOptionalArgs = [] + , _appStore = store + , _appDatabaseConnStr = DbConnDescriptor "" + , _appDatabaseType = "none" + , _appStoreData = storeData + , _appLinearMigrations = True + , _appTimestampFilenames = False + } + +prepareStateWith :: AppState -> String -> IO AppState +prepareStateWith state m = do + Right storeData <- loadMigrations $ _appStore state + return state { _appRequiredArgs = [m], _appStoreData = storeData } + +prepareNormalState :: String -> IO AppState +prepareNormalState m = do + state <- prepareState m + return $ state { _appLinearMigrations = False } diff --git a/test/TestDriver.hs b/test/TestDriver.hs --- a/test/TestDriver.hs +++ b/test/TestDriver.hs @@ -13,6 +13,8 @@ import qualified FilesystemTest import qualified CycleDetectionTest import qualified StoreTest +import qualified LinearMigrationsTest +import qualified ConfigurationTest import Control.Monad ( forM ) import Control.Exception ( finally, catch, SomeException ) @@ -40,6 +42,10 @@ return $ "Filesystem Parsing" ~: test fspTests , do fsTests <- FilesystemTest.tests return $ "Filesystem general" ~: test fsTests + , do linTests <- LinearMigrationsTest.tests + return $ "Linear migrations" ~: test linTests + , do cfgTests <- ConfigurationTest.tests + return $ "Configuration tests" ~: test cfgTests ] return $ concat [ backendTests , ioTests