dbmigrations 0.3 → 0.5
raw patch · 6 files changed
+125/−680 lines, 6 filesdep +bytestringdep +yaml-lightdep −parsecdep ~HDBCdep ~containersdep ~filepath
Dependencies added: bytestring, yaml-light
Dependencies removed: parsec
Dependency ranges changed: HDBC, containers, filepath
Files
- README +27/−9
- dbmigrations.cabal +12/−9
- src/Database/Schema/Migrations/Backend/HDBC.hs +1/−1
- src/Database/Schema/Migrations/Filesystem.hs +48/−26
- src/Database/Schema/Migrations/Filesystem/Parse.hs +0/−83
- src/Moo.hs +37/−552
README view
@@ -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 ------------------------
dbmigrations.cabal view
@@ -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
src/Database/Schema/Migrations/Backend/HDBC.hs view
@@ -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
src/Database/Schema/Migrations/Filesystem.hs view
@@ -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 }
− src/Database/Schema/Migrations/Filesystem/Parse.hs
@@ -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"
src/Moo.hs view
@@ -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