diff --git a/README b/README --- a/README +++ b/README @@ -26,9 +26,10 @@ While the "moo" management tool included in this package will create new migration files for you, a description of the file format follows. -A migration used by this package is a structured document containing -these fields: +A migration used by this package is a structured document in YAML +format containing these fields: + Description: (optional) a textual description of the migration Dependencies: (required, but may be empty) a whitespace-separated @@ -45,13 +46,30 @@ Revert: (optional) The SQL necessary to revert this migration from the database -The format of this file is somewhat flexible; any of the above fields -may take up a single line, with all text coming after the field name -and colon constituting the field's value; in the case of multi-line -values (such as Apply and Revert SQL), multiple lines may follow the -field name and colon, as long as they are indented by at least one -whitespace character. The migration file format also supports -comments, which are preceded by "#". +The format of this file is somewhat flexible; please see the YAML 1.2 +format specification for a full description of syntax features. I +recommend appending "|" to the Apply and Revert fields if they contain +multi-line SQL that you want to keep that way, e.g., + + Apply: | + CREATE OR REPLACE FUNCTION ... + ... + ... + + Revert: | + DROP TABLE foo; + DROP TABLE bar; + +Note that this is only *necessary* when concatenating the lines would +have a different meaning, e.g., + + Apply: + -- Comment here + CREATE TABLE; + +Without "|" on the "Apply:" line, the above text would be collapsed to +"-- Comment here CREATE TABLE;" which is probably not what you want. +For a full treatment of this behavior, see the YAML spec. moo: the management tool ------------------------ diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 0.3 +Version: 0.5 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -24,10 +24,13 @@ Build-Type: Simple License: BSD3 License-File: LICENSE -Cabal-Version: >= 1.2 -Homepage: http://repos.codevine.org/dbmigrations/ +Cabal-Version: >= 1.6 Data-Files: README MOO.TXT +Source-Repository head + type: git + location: git://github.com/jtdaugherty/dbmigrations.git + Flag testing Description: Build for testing Default: False @@ -41,16 +44,17 @@ Build-Depends: base >= 4 && < 5, - HDBC >= 2.2.1 && < 2.3, + HDBC >= 2.2.1 && < 2.4, time >= 1.1 && < 1.2, random >= 1.0 && < 1.1, - containers >= 0.2 && < 0.4, + containers >= 0.2 && < 0.6, mtl >= 1.1 && < 1.2, - parsec >= 2.1 && < 2.2, - filepath >= 1.1 && < 1.2, + filepath >= 1.1 && < 1.4, directory >= 1.0 && < 1.2, fgl >= 5.4 && < 5.5, - template-haskell + template-haskell, + yaml-light >= 0.1 && < 0.2, + bytestring >= 0.9 && < 1.0 Hs-Source-Dirs: src Exposed-Modules: @@ -64,7 +68,6 @@ Other-Modules: Database.Schema.Migrations.CycleDetection - Database.Schema.Migrations.Filesystem.Parse Database.Schema.Migrations.Filesystem.Serialize Executable dbmigrations-tests 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 @@ -58,4 +58,4 @@ getMigrations conn = do results <- quickQuery' conn ("SELECT migration_id FROM " ++ migrationTableName) [] - return $ map (\(h:_) -> fromSql h) results + return $ map (fromSql . head) results 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,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, ScopedTypeVariables #-} -- |This module provides a type for interacting with a -- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem @@ -8,23 +8,29 @@ ) where +import Prelude hiding ( catch ) + 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 ) import Data.Time.Clock ( UTCTime ) import Data.Time () -- for UTCTime Show instance +import qualified Data.Map as Map +import Control.Applicative ( (<$>) ) import Control.Monad ( filterM ) +import Control.Exception ( IOException, Exception(..), throw, catch ) -import Text.ParserCombinators.Parsec ( parse ) +import Data.Yaml.YamlLight import Database.Schema.Migrations.Migration ( Migration(..) , newMigration ) -import Database.Schema.Migrations.Filesystem.Parse import Database.Schema.Migrations.Filesystem.Serialize import Database.Schema.Migrations.Store @@ -32,6 +38,14 @@ data FilesystemStore = FSStore { storePath :: FilePath } +data FilesystemStoreError = FilesystemStoreError String + deriving (Show, Typeable) + +instance Exception FilesystemStoreError + +throwFS :: String -> a +throwFS = throw . FilesystemStoreError + filenameExtension :: String filenameExtension = ".txt" @@ -71,43 +85,54 @@ -- error message. migrationFromPath :: FilePath -> IO (Either String Migration) migrationFromPath path = do - contents <- readFile path let name = takeBaseName $ takeFileName path - case parse migrationParser path contents of - Left _ -> return $ Left $ "Could not parse migration file " ++ (show path) - Right fields -> - do - let missing = missingFields fields - case length missing of - 0 -> do - newM <- newMigration "" - case migrationFromFields newM fields of - Nothing -> return $ Left $ "Unrecognized field in migration " ++ (show path) - Just m -> return $ Right $ m { mId = name } - _ -> return $ Left $ "Missing required field(s) in migration " ++ (show path) ++ ": " ++ (show missing) + (Right <$> process name) `catch` (\(FilesystemStoreError s) -> return $ Left s) -missingFields :: FieldSet -> [FieldName] + where + process name = do + yaml <- parseYamlFile path `catch` (\(e::IOException) -> throwFS $ show e) + + -- Convert yaml structure into basic key/value map + let fields = getFields yaml + missing = missingFields fields + + case length missing of + 0 -> do + newM <- newMigration "" + case migrationFromFields newM fields of + Nothing -> throwFS $ "Error in " ++ (show path) ++ ": unrecognized field found" + Just m -> return $ m { mId = name } + _ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing) + +getFields :: YamlLight -> [(String, String)] +getFields (YMap mp) = map toPair $ Map.assocs mp + where + toPair (YStr k, YStr v) = (unpack k, unpack v) + toPair (k, v) = throwFS $ "Error in YAML input; expected string key and string value, got " ++ (show (k, v)) +getFields _ = throwFS "Error in YAML input; expected mapping" + +missingFields :: [(String, String)] -> [String] missingFields fs = - [ k | k <- requiredFields, not (k `elem` inputFieldNames) ] + [ k | k <- requiredFields, not (k `elem` inputStrings) ] where - inputFieldNames = [ n | (n, _) <- fs ] + inputStrings = map fst fs -- |Given a migration and a list of parsed migration fields, update -- the migration from the field values for recognized fields. -migrationFromFields :: Migration -> FieldSet -> Maybe Migration +migrationFromFields :: Migration -> [(String, String)] -> Maybe Migration migrationFromFields m [] = Just m migrationFromFields m ((name, value):rest) = do processor <- lookup name fieldProcessors newM <- processor value m migrationFromFields newM rest -requiredFields :: [FieldName] +requiredFields :: [String] requiredFields = [ "Created" , "Apply" , "Depends" ] -fieldProcessors :: [(FieldName, FieldProcessor)] +fieldProcessors :: [(String, FieldProcessor)] fieldProcessors = [ ("Created", setTimestamp ) , ("Description", setDescription ) , ("Apply", setApply ) @@ -135,7 +160,4 @@ setRevert revert m = Just $ m { mRevert = Just revert } setDepends :: FieldProcessor -setDepends depString m = do - case parse parseDepsList "-" depString of - Left _ -> Nothing - Right depIds -> Just $ m { mDeps = depIds } +setDepends depString m = Just $ m { mDeps = words depString } diff --git a/src/Database/Schema/Migrations/Filesystem/Parse.hs b/src/Database/Schema/Migrations/Filesystem/Parse.hs deleted file mode 100644 --- a/src/Database/Schema/Migrations/Filesystem/Parse.hs +++ /dev/null @@ -1,83 +0,0 @@ -module Database.Schema.Migrations.Filesystem.Parse - ( migrationParser - , parseDepsList - , FieldName - , Field - , FieldSet - ) -where - -import Data.Time.Clock () -import Data.Maybe ( catMaybes ) - -import Text.ParserCombinators.Parsec - -type FieldName = String -type Field = (FieldName, String) -type FieldSet = [Field] - --- |Parse a migration document and return a list of parsed fields and --- a list of claimed dependencies. -migrationParser :: Parser [Field] -migrationParser = do - result <- many (parseField <|> parseComment <|> parseEmptyLine) - return $ catMaybes result - -parseDepsList :: Parser [String] -parseDepsList = - depsList <|> (many whitespace >> eol >> return []) - where - parseMID = many1 (alphaNum <|> oneOf "-._") - separator = discard $ spaces >> many (newline >> spaces) - depsList = do - many whitespace - first <- parseMID - rest <- many $ try $ do - separator - parseMID - eol - return (first : rest) - -discard :: Parser a -> Parser () -discard = (>> return ()) - -eol :: Parser () -eol = (discard newline) <|> (discard eof) - -whitespace :: Parser Char -whitespace = oneOf " \t" - -requiredWhitespace :: Parser String -requiredWhitespace = many1 whitespace - -parseFieldName :: Parser FieldName -parseFieldName = many1 (alphaNum <|> char '-') - -parseComment :: Parser (Maybe Field) -parseComment = do - discard $ do - many whitespace - char '#' - manyTill anyChar eol - return Nothing - -parseEmptyLine :: Parser (Maybe Field) -parseEmptyLine = newline >> return Nothing - -parseField :: Parser (Maybe Field) -parseField = do - name <- parseFieldName - char ':' - many whitespace - rest <- manyTill anyChar eol - otherLines <- otherContentLines - let value = rest ++ (concat otherLines) - return $ Just (name, value) - -otherContentLines :: Parser [String] -otherContentLines = - many $ try $ (discard newline >> return "") <|> do - ws <- requiredWhitespace - rest <- manyTill anyChar eol - -- Retain leading whitespace and trailing newline - return $ ws ++ rest ++ "\n" diff --git a/src/Moo.hs b/src/Moo.hs --- a/src/Moo.hs +++ b/src/Moo.hs @@ -1,528 +1,27 @@ -{-# LANGUAGE FlexibleContexts, ExistentialQuantification #-} module Main ( main ) where -import System.Environment ( getArgs, getEnvironment, getProgName ) -import System.Exit ( exitWith, ExitCode(..), exitSuccess ) -import System.IO ( stdout, hFlush, hGetBuffering - , hSetBuffering, stdin, BufferMode(..) - ) -import Control.Exception ( bracket ) -import Data.Maybe ( listToMaybe, catMaybes, isJust - , fromJust, isNothing - ) -import Data.List ( intercalate, sortBy, isPrefixOf ) -import Control.Monad.Reader ( ReaderT, asks, runReaderT ) -import Control.Monad ( when, forM_ ) -import Control.Monad.Trans ( liftIO ) -import Control.Applicative ( (<$>) ) -import Database.HDBC.PostgreSQL ( connectPostgreSQL ) -import Database.HDBC.Sqlite3 ( connectSqlite3 ) -import Database.HDBC ( IConnection(commit, rollback, disconnect) - , catchSql, seErrorMsg, SqlError - ) -import Database.Schema.Migrations -import Database.Schema.Migrations.Filesystem -import Database.Schema.Migrations.Migration ( Migration(..) ) -import Database.Schema.Migrations.Backend ( Backend, applyMigration - , revertMigration, getMigrations - , rootMigrationName - ) -import Database.Schema.Migrations.Store ( loadMigrations - , fullMigrationName - , StoreData - , storeMigrations - , storeLookup - ) -import Database.Schema.Migrations.Backend.HDBC () --- 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 :: [CommandOption] - , cDescription :: String - , cHandler :: CommandHandler - } +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) -newtype DbConnDescriptor = DbConnDescriptor String +import Database.Schema.Migrations.Filesystem ( FilesystemStore (..) ) +import Database.Schema.Migrations.Store +import Moo.CommandInterface +import Moo.Core --- Application state which can be accessed by any command handler. -data AppState = AppState { appOptions :: [CommandOption] - , appCommand :: Command - , appRequiredArgs :: [String] - , appOptionalArgs :: [String] - , appStore :: FilesystemStore - , appDatabaseConnStr :: Maybe DbConnDescriptor - , appDatabaseType :: Maybe String - , appStoreData :: 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 () - --- Options which can be used to alter command behavior -data CommandOption = Test - | NoAsk - deriving (Eq) - --- Type wrapper for IConnection instances so the makeConnection --- function can return any type of connection. -data AnyIConnection = forall c. (IConnection c) => AnyIConnection c - --- The types for choices the user can make when being prompted for --- dependencies. -data AskDepsChoice = Yes | No | View | Done | Quit - deriving (Eq) - --- 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 - --- 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 - --- 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"))] - --- Different command-line option strings and their constructors. -optionMap :: [(String, CommandOption)] -optionMap = [ ("--test", Test) - , ("--no-ask", NoAsk)] - --- Usage information for each CommandOption. -optionUsage :: CommandOption -> String -optionUsage Test = "Perform the action in a transaction and issue a \ - \rollback when finished" -optionUsage NoAsk = "Do not interactively ask any questions, just do it" - --- Is the specified option turned on in the application state? -hasOption :: CommandOption -> AppT Bool -hasOption o = asks ((o `elem`) . appOptions) - --- Is the specified option string mapped to an option constructor? -isSupportedCommandOption :: String -> Bool -isSupportedCommandOption s = isJust $ lookup s optionMap - --- Does the specified string appear to be a command-line option? -isCommandOption :: String -> Bool -isCommandOption s = "--" `isPrefixOf` s - --- Given a list of strings, convert it into a list of well-typed --- command options and remaining arguments, or return an error if any --- options are unsupported. -convertOptions :: [String] -> Either String ([CommandOption], [String]) -convertOptions args = if null unsupportedOptions - then Right (supportedOptions, rest) - else Left unsupported - where - allOptions = filter isCommandOption args - supportedOptions = catMaybes $ map (\s -> lookup s optionMap) args - unsupportedOptions = [ s | s <- allOptions - , not $ isSupportedCommandOption s ] - rest = [arg | arg <- args, not $ isCommandOption arg] - unsupported = "Unsupported option(s): " - ++ intercalate ", " unsupportedOptions - --- The available commands; used to dispatch from the command line and --- used to generate usage output. -commands :: [Command] -commands = [ Command "new" ["migration_name"] [] [NoAsk] - "Create a new empty migration" - newCommand - , Command "apply" ["migration_name"] [] [Test] - "Apply the specified migration and its dependencies" - applyCommand - , Command "revert" ["migration_name"] [] [Test] - "Revert the specified migration and those that depend\ - \ on it" - revertCommand - , Command "test" ["migration_name"] [] [] - "Test the specified migration by applying and \ - \reverting it in a transaction, then roll back" - testCommand - , Command "upgrade" [] [] [Test] - "Install all migrations that have not yet been \ - \installed" - upgradeCommand - , Command "upgrade-list" [] [] [] - "Show the list of migrations not yet installed" - upgradeListCommand - , Command "reinstall" ["migration_name"] [] [Test] - "Reinstall a migration by reverting, then reapplying it" - reinstallCommand - , Command "list" [] [] [] - "List migrations already installed in the backend" - listCommand - ] - --- The values of DBM_DATABASE_TYPE and their corresponding connection --- factory functions. -databaseTypes :: [(String, String -> IO AnyIConnection)] -databaseTypes = [ ("postgresql", fmap AnyIConnection . connectPostgreSQL) - , ("sqlite3", fmap AnyIConnection . connectSqlite3) - ] - --- 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 - --- 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) - --- 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")) - ] - --- 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 - do - 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) - when (not $ null $ mDeps m) - (putStrLn $ " Deps: " ++ - (intercalate "\n " $ mDeps m)) - -- ask again - interactiveAskDeps' storeData (name:rest) - Quit -> do - putStrLn "cancelled." - exitWith (ExitFailure 1) - Done -> return [] - --- 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)) - ] - -newCommand :: CommandHandler -newCommand storeData = do - required <- asks appRequiredArgs - store <- asks appStore - let [migrationId] = required - noAsk <- hasOption NoAsk - - 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 <- hasOption Test - 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 . (" " ++)) - reportSqlError :: SqlError -> IO a reportSqlError e = do putStrLn $ "\n" ++ "A database error occurred: " ++ seErrorMsg e exitWith (ExitFailure 1) -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 = do - 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 = do - 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' - -reinstallCommand :: CommandHandler -reinstallCommand storeData = do - isTesting <- hasOption Test - required <- asks appRequiredArgs - let [migrationId] = required - - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn - m <- lookupMigration storeData migrationId - - revert m storeData conn - apply m storeData conn True - - case isTesting of - False -> do - commit conn - putStrLn "Migration successfully reinstalled." - True -> do - rollback conn - putStrLn "Reinstall test successful." - -listCommand :: CommandHandler -listCommand _ = do - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn - ms <- getMigrations conn - forM_ ms $ \m -> - when (not $ m == rootMigrationName) $ putStrLn m - -applyCommand :: CommandHandler -applyCommand storeData = do - isTesting <- hasOption Test - required <- asks appRequiredArgs - let [migrationId] = required - - withConnection $ \(AnyIConnection conn) -> do - ensureBootstrappedBackend conn >> commit conn - m <- lookupMigration storeData migrationId - apply m storeData conn True - case isTesting of - False -> do - commit conn - putStrLn "Successfully applied migrations." - True -> do - rollback conn - putStrLn "Migration installation test successful." - -revertCommand :: CommandHandler -revertCommand storeData = do - isTesting <- hasOption Test - required <- asks appRequiredArgs - let [migrationId] = required - - 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." - -usageString :: Command -> String -usageString command = - intercalate " " ((cName command):requiredArgs ++ - optionalArgs ++ options) - where - requiredArgs = map (\s -> "<" ++ s ++ ">") $ cRequired command - optionalArgs = map (\s -> "[" ++ s ++ "]") $ cOptional command - options = map (\s -> "[" ++ s ++ "]") $ optionStrings - optionStrings = map (\o -> fromJust $ lookup o flippedOptions) $ - cAllowedOptions command - flippedOptions = map (\(a,b) -> (b,a)) optionMap - usage :: IO a usage = do progName <- getProgName @@ -531,82 +30,68 @@ putStrLn "Environment:" putStrLn $ " " ++ envDatabaseName ++ ": database connection string" putStrLn $ " " ++ envDatabaseType ++ ": database type, one of " ++ - (intercalate "," $ map fst databaseTypes) + intercalate "," (map fst databaseTypes) putStrLn $ " " ++ envStoreName ++ ": path to migration store" putStrLn "Commands:" forM_ commands $ \command -> do putStrLn $ " " ++ usageString command - putStrLn $ " " ++ cDescription command + putStrLn $ " " ++ _cDescription command putStrLn "" - putStrLn "Options:" - forM_ optionMap $ \(name, option) -> do - putStrLn $ " " ++ name ++ ": " ++ optionUsage option + putStrLn commandOptionUsage exitWith (ExitFailure 1) + usageSpecific :: Command -> IO a usageSpecific command = do putStrLn $ "Usage: initstore-fs " ++ usageString command exitWith (ExitFailure 1) -findCommand :: String -> Maybe Command -findCommand name = listToMaybe [ c | c <- commands, cName c == name ] -envDatabaseType :: String -envDatabaseType = "DBM_DATABASE_TYPE" - -envDatabaseName :: String -envDatabaseName = "DBM_DATABASE" - -envStoreName :: String -envStoreName = "DBM_MIGRATION_STORE" - main :: IO () main = do allArgs <- getArgs when (null allArgs) usage - let (commandName:unprocessedArgs) = allArgs - (opts, args) <- case convertOptions unprocessedArgs of - Left e -> putStrLn e >> usage - Right c -> return c 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 = case lookup envStoreName env of - Just sp -> sp - Nothing -> error $ "Error: missing required environment \ - \variable " ++ envStoreName + mDbType = lookup envDatabaseType env + storePathStr = fromMaybe + (error $ + "Error: missing required environment \ + \variable " ++ envStoreName) + (lookup envStoreName env) - let (required,optional) = splitAt (length $ cRequired command) args - store = FSStore { storePath = storePathStr } + let store = FSStore { storePath = storePathStr } - if (length args) < (length $ cRequired command) then + if length required < length ( _cRequired command) then usageSpecific command else do loadedStoreData <- loadMigrations store case loadedStoreData of Left es -> do putStrLn "There were errors in the migration store:" - forM_ es $ \err -> do - putStrLn $ " " ++ show err + forM_ es $ \err -> putStrLn $ " " ++ show err Right storeData -> do - let st = AppState { appOptions = opts - , appCommand = command - , appRequiredArgs = required - , appOptionalArgs = optional - , appDatabaseConnStr = DbConnDescriptor <$> mDbConnStr - , appDatabaseType = mDbType - , appStore = FSStore { storePath = storePathStr } - , appStoreData = storeData + let st = AppState { _appOptions = opts + , _appCommand = command + , _appRequiredArgs = required + , _appOptionalArgs = ["" :: String] + , _appDatabaseConnStr = DbConnDescriptor <$> + mDbConnStr + , _appDatabaseType = mDbType + , _appStore = FSStore storePathStr + , _appStoreData = storeData } - (runReaderT (cHandler command $ storeData) st) `catchSql` reportSqlError + runReaderT (_cHandler command storeData) st `catchSql` reportSqlError