diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 0.6 +Version: 0.7 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -50,11 +50,13 @@ containers >= 0.2 && < 0.6, mtl == 2.1.*, filepath >= 1.1 && < 1.4, - directory >= 1.0 && < 1.2, + directory >= 1.0 && < 1.3, fgl >= 5.4 && < 5.5, template-haskell, yaml-light >= 0.1 && < 0.2, - bytestring >= 0.9 && < 1.0 + bytestring >= 0.9 && < 1.0, + text == 0.11.*, + configurator == 0.2.* Hs-Source-Dirs: src Exposed-Modules: @@ -69,6 +71,10 @@ Other-Modules: Database.Schema.Migrations.CycleDetection Database.Schema.Migrations.Filesystem.Serialize + Moo.CommandHandlers + Moo.CommandInterface + Moo.CommandUtils + Moo.Core Executable dbmigrations-tests Build-Depends: diff --git a/src/Moo.hs b/src/Moo.hs --- a/src/Moo.hs +++ b/src/Moo.hs @@ -2,26 +2,26 @@ ( main ) where -import Control.Monad.Reader (forM_, runReaderT, when) -import Control.Applicative ((<$>)) -import Data.List (intercalate) -import Data.Maybe (fromMaybe) -import System.Exit (ExitCode (ExitFailure), exitWith) -import System.Environment (getArgs, getEnvironment, getProgName) -import Database.HDBC (SqlError, catchSql, seErrorMsg) - -import Database.Schema.Migrations.Filesystem ( FilesystemStore (..) ) -import Database.Schema.Migrations.Store -import Moo.CommandInterface -import Moo.Core - +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 @@ -41,12 +41,14 @@ putStrLn commandOptionUsage exitWith (ExitFailure 1) - usageSpecific :: Command -> IO a usageSpecific command = do putStrLn $ "Usage: initstore-fs " ++ usageString command exitWith (ExitFailure 1) +loadConfiguration :: Maybe FilePath -> IO Configuration +loadConfiguration Nothing = liftM fromShellEnvironment getEnvironment +loadConfiguration (Just path) = fromConfigurator =<< load [Required path] main :: IO () main = do @@ -56,23 +58,20 @@ command <- case findCommand commandName of Nothing -> usage - Just c -> return c + Just c -> return c (opts, required) <- getCommandArgs unprocessedArgs - -- Read store path and database connection string from environment - -- or config file (for now, we just look at the environment). Also, - -- require them both to be set for every operation, even though some - -- operations only require the store path. - env <- getEnvironment - let mDbConnStr = lookup envDatabaseName env - mDbType = lookup envDatabaseType env - storePathStr = fromMaybe - (error $ - "Error: missing required environment \ - \variable " ++ envStoreName) - (lookup envStoreName env) + 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 @@ -84,14 +83,13 @@ 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 = DbConnDescriptor <$> - mDbConnStr - , _appDatabaseType = mDbType - , _appStore = FSStore storePathStr - , _appStoreData = storeData + 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 diff --git a/src/Moo/CommandHandlers.hs b/src/Moo/CommandHandlers.hs new file mode 100644 --- /dev/null +++ b/src/Moo/CommandHandlers.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Moo.CommandHandlers where + +import Moo.Core +import Moo.CommandUtils +import Control.Monad ( when, forM_ ) +import Data.Maybe ( isJust ) +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.Backend + + +newCommand :: CommandHandler +newCommand storeData = do + required <- asks _appRequiredArgs + store <- asks _appStore + let [migrationId] = required + noAsk <- fmap _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 + + result <- if noAsk then (return True) else + (confirmCreation migrationId deps) + + case result of + True -> do + status <- createNewMigration store migrationId deps + case status of + Left e -> putStrLn e >> (exitWith (ExitFailure 1)) + Right _ -> putStrLn $ "Migration created successfully: " ++ + show fullPath + 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 + when (null migrationNames) $ do + putStrLn "Database is up to date." + exitSuccess + forM_ migrationNames $ \migrationName -> do + m <- lookupMigration storeData migrationName + apply m storeData conn False + case isTesting of + True -> do + rollback conn + putStrLn "Upgrade test successful." + False -> do + commit conn + putStrLn "Database successfully upgraded." + + +upgradeListCommand :: CommandHandler +upgradeListCommand storeData = do + withConnection $ \(AnyIConnection conn) -> do + ensureBootstrappedBackend conn >> commit conn + migrationNames <- missingMigrations conn 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 + 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 <- fmap _test $ asks _appOptions + required <- asks _appRequiredArgs + let [migrationId] = required + + withConnection $ \(AnyIConnection conn) -> do + ensureBootstrappedBackend conn >> commit conn + m <- lookupMigration storeData migrationId + 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 <- fmap _test $ asks _appOptions + required <- asks _appRequiredArgs + let [migrationId] = required + + withConnection $ \(AnyIConnection conn) -> do + ensureBootstrappedBackend conn >> commit conn + m <- lookupMigration storeData migrationId + revert m storeData conn + + 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 + let [migrationId] = required + + withConnection $ \(AnyIConnection conn) -> do + ensureBootstrappedBackend conn >> commit conn + m <- lookupMigration storeData migrationId + migrationNames <- missingMigrations conn storeData + -- If the migration is already installed, remove it as part of + -- the test + when (not $ migrationId `elem` migrationNames) $ + do revert m storeData conn + return () + applied <- apply m storeData conn True + forM_ (reverse applied) $ \migration -> do + revert migration storeData conn + rollback conn + putStrLn "Successfully tested migrations." diff --git a/src/Moo/CommandInterface.hs b/src/Moo/CommandInterface.hs new file mode 100644 --- /dev/null +++ b/src/Moo/CommandInterface.hs @@ -0,0 +1,135 @@ +-- |This module defines the MOO command interface, the commnad line options +-- parser, and helpers to manipulate the Command data structure. +module Moo.CommandInterface + ( commands + , commandOptionUsage + , findCommand + , getCommandArgs + , usageString + ) where + +import Data.Maybe +import Moo.CommandHandlers +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 +-- used to generate usage output. +commands :: [Command] +commands = [ Command "new" [migrationName] + [] + ["no-ask", configFile] + "Create a new empty migration" + newCommand + + , Command "apply" [migrationName] + [] + [testOption, configFile] + "Apply the specified migration and its \ + \dependencies" + applyCommand + + , Command "revert" [migrationName] + [] + [testOption, configFile] + "Revert the specified migration and those \ + \that depend on it" + revertCommand + + , Command "test" [migrationName] + [] + [configFile] + "Test the specified migration by applying \ + \and reverting it in a transaction, then \ + \roll back" + testCommand + + , Command "upgrade" [] + [] + [testOption, configFile] + "Install all migrations that have not yet \ + \been installed" + + upgradeCommand + + , Command "upgrade-list" [] + [] + [] + "Show the list of migrations not yet \ + \installed" + upgradeListCommand + + , Command "reinstall" [migrationName] + [] + [testOption, configFile] + "Reinstall a migration by reverting, then \ + \reapplying it" + reinstallCommand + + , Command "list" [] + [] + [configFile] + "List migrations already installed in the backend" + listCommand + ] + where migrationName = "migrationName" + testOption = "test" + configFile = "config-file" + + +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 = + unwords (_cName command:optionalArgs ++ options ++ requiredArgs) + where + requiredArgs = map (\s -> "<" ++ s ++ ">") $ _cRequired command + optionalArgs = map (\s -> "[" ++ s ++ "]") $ _cOptional command + options = map (\s -> "["++ "--" ++ s ++ "]") optionStrings + optionStrings = _cAllowedOptions command diff --git a/src/Moo/CommandUtils.hs b/src/Moo/CommandUtils.hs new file mode 100644 --- /dev/null +++ b/src/Moo/CommandUtils.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Moo.CommandUtils + ( apply + , confirmCreation + , interactiveAskDeps + , lookupMigration + , revert + , withConnection + ) 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.Maybe ( fromJust, isNothing, 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.Migration ( Migration(..) ) +import Database.Schema.Migrations.Store ( StoreData + , storeLookup + , storeMigrations + ) +import Moo.Core + + +apply :: (IConnection b, Backend b IO) + => Migration -> StoreData -> b -> Bool -> IO [Migration] +apply m storeData backend complain = do + -- Get the list of migrations to apply + toApply <- migrationsToApply storeData backend m + + -- Apply them + if null toApply then + nothingToDo >> return [] else + mapM_ (applyIt backend) toApply >> return toApply + + where + nothingToDo = + when complain $ + putStrLn $ "Nothing to do; " ++ + mId m ++ + " already installed." + + applyIt conn it = do + putStr $ "Applying: " ++ mId it ++ "... " + applyMigration conn it + putStrLn "done." + + +revert :: (IConnection b, Backend b IO) + => Migration -> StoreData -> b -> IO [Migration] +revert m storeData backend = do + -- Get the list of migrations to revert + toRevert <- liftIO $ migrationsToRevert storeData backend m + + -- Revert them + if null toRevert then + nothingToDo >> return [] else + mapM_ (revertIt backend) toRevert >> return toRevert + + where + nothingToDo = + putStrLn $ "Nothing to do; " ++ + mId m ++ + " not installed." + + revertIt conn it = do + putStr $ "Reverting: " ++ mId it ++ "... " + revertMigration conn it + putStrLn "done." + + +lookupMigration :: StoreData -> String -> IO Migration +lookupMigration storeData name = do + let theMigration = storeLookup storeData name + case theMigration of + Nothing -> do + putStrLn $ "No such migration: " ++ name + 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) = + case lookup dbType databaseTypes of + Nothing -> error $ "Unsupported database type " ++ show dbType ++ + " (supported types: " ++ + intercalate "," (map fst databaseTypes) ++ ")" + Just mkConnection -> mkConnection 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 + + +-- Given a migration name and selected dependencies, get the user's +-- confirmation that a migration should be created. +confirmCreation :: String -> [String] -> IO Bool +confirmCreation migrationId deps = do + putStrLn "" + putStrLn $ "Confirm: create migration '" ++ migrationId ++ "'" + if null deps then putStrLn " (No dependencies)" + else putStrLn "with dependencies:" + forM_ deps $ \d -> putStrLn $ " " ++ d + prompt "Are you sure?" [ ('y', (True, Nothing)) + , ('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. +prompt :: (Eq a) => String -> PromptChoices a -> IO a +prompt _ [] = error "prompt requires a list of choices" +prompt message choiceMap = do + putStr $ message ++ " (" ++ choiceStr ++ helpChar ++ "): " + hFlush stdout + c <- unbufferedGetChar + case lookup c choiceMap of + Nothing -> do + when (c /= '\n') $ putStrLn "" + when (c == 'h') $ putStr $ mkPromptHelp choiceMapWithHelp + retry + Just (val, _) -> putStrLn "" >> return val + where + retry = prompt message choiceMap + choiceStr = intercalate "" $ map (return . fst) choiceMap + 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 +mkPromptHelp choices = + 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 +unbufferedGetChar = do + bufferingMode <- hGetBuffering stdin + hSetBuffering stdin NoBuffering + c <- getChar + 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] +interactiveAskDeps storeData = do + -- For each migration in the store, starting with the most recently + -- added, ask the user if it should be added to a dependency list + let sorted = sortBy compareTimestamps $ storeMigrations storeData + interactiveAskDeps' storeData (map mId sorted) + 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. +interactiveAskDeps' :: StoreData -> [String] -> IO [String] +interactiveAskDeps' _ [] = return [] +interactiveAskDeps' storeData (name:rest) = do + result <- prompt ("Depend on '" ++ name ++ "'?") askDepsChoices + if result == Done then return [] else + case result of + Yes -> do + next <- interactiveAskDeps' storeData rest + return $ name:next + No -> interactiveAskDeps' storeData rest + View -> do + -- load migration + let Just m = storeLookup storeData name + -- print out description, timestamp, deps + when (isJust $ mDesc m) + (putStrLn $ " Description: " ++ + fromJust (mDesc m)) + putStrLn $ " Created: " ++ show (mTimestamp m) + unless (null $ mDeps m) + (putStrLn $ " Deps: " ++ + intercalate "\n " (mDeps m)) + -- ask again + interactiveAskDeps' storeData (name:rest) + Quit -> do + putStrLn "cancelled." + exitWith (ExitFailure 1) + Done -> return [] + + +-- The choices the user can make when being prompted for dependencies. +askDepsChoices :: PromptChoices AskDepsChoice +askDepsChoices = [ ('y', (Yes, Just "yes, depend on this migration")) + , ('n', (No, Just "no, do not depend on this migration")) + , ('v', (View, Just "view migration details")) + , ('d', (Done, Just "done, do not ask me about more dependencies")) + , ('q', (Quit, Just "cancel this operation and quit")) + ] diff --git a/src/Moo/Core.hs b/src/Moo/Core.hs new file mode 100644 --- /dev/null +++ b/src/Moo/Core.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Moo.Core where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad.Reader (ReaderT) +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 Database.Schema.Migrations () +import Database.Schema.Migrations.Backend.HDBC () +import Database.Schema.Migrations.Filesystem (FilesystemStore) +import Database.Schema.Migrations.Store (StoreData) + + +-- |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 + , _appStoreData :: StoreData + } + +type ShellEnvironment = [(String, String)] + +data Configuration = Configuration + { _connectionString :: Maybe String + , _databaseType :: Maybe String + , _migrationStorePath :: Maybe FilePath + } + +fromShellEnvironment :: ShellEnvironment -> 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 + + +-- |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 + , _test :: Bool + , _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 + , _cRequired :: [String] + , _cOptional :: [String] + , _cAllowedOptions :: [String] + , _cDescription :: String + , _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) + ] + +envDatabaseType :: String +envDatabaseType = "DBM_DATABASE_TYPE" + +envDatabaseName :: String +envDatabaseName = "DBM_DATABASE" + +envStoreName :: String +envStoreName = "DBM_MIGRATION_STORE"