dbmigrations (empty) → 0.1
raw patch · 15 files changed
+1837/−0 lines, 15 filesdep +HDBCdep +HDBC-postgresqldep +HUnitsetup-changed
Dependencies added: HDBC, HDBC-postgresql, HUnit, base, containers, directory, fgl, filepath, hscurses, mtl, parsec, process, random, template-haskell, time
Files
- LICENSE +30/−0
- MOO.TXT +73/−0
- README +109/−0
- Setup.lhs +3/−0
- dbmigrations.cabal +88/−0
- src/Database/Schema/Migrations.hs +103/−0
- src/Database/Schema/Migrations/Backend.hs +51/−0
- src/Database/Schema/Migrations/Backend/HDBC.hs +59/−0
- src/Database/Schema/Migrations/Dependencies.hs +101/−0
- src/Database/Schema/Migrations/Filesystem.hs +131/−0
- src/Database/Schema/Migrations/Migration.hs +41/−0
- src/Database/Schema/Migrations/Store.hs +132/−0
- src/Moo.hs +561/−0
- src/StoreManager.hs +272/−0
- test/TestDriver.hs +83/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2009, Josh Hoyt.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of the contributors may not be used to endorse or+ promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ MOO.TXT view
@@ -0,0 +1,73 @@++moo: the dbmigrations management tool+-------------------------------------++Before using moo, you must set two environment variables:++ DBM_DATABASE_TYPE++ The type of database you'll be managing. The only supported value+ at present is "postgresql". This will determine the format of+ DBM_DATABASE.++ DBM_DATABASE++ The database connection string for the database you'll be+ managing. The connection strings for each supported database type+ are as follows:++ DBM_DATABASE_TYPE=postgresql:++ The format of this value is a PostgreSQL database connection+ string, i.e., that described at:++ http://www.postgresql.org/docs/8.1/static/libpq.html#LIBPQ-CONNECT++ DBM_MIGRATION_STORE++ The path to the filesystem directory where your migrations will be+ kept. moo will create new migrations in this directory and use+ the migrations in this directory when updating the database+ schema. Initially, you'll probably set this to an extant (but+ empty) directory. moo will not create it for you.++Commands+--------++ new <migration name>: 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.++ apply <migration name>: apply the specified migration (and its+ dependencies) to the database. This operation will be performed+ in a single transaction which will be rolled back if an error+ occurs. moo will output updates as each migration is applied.++ revert <migration name>: revert the specified migration (and its+ reverse dependencies -- the migrations which depend on it) from+ the database. This operation will be performed in a single+ transaction which will be rolled back if an error occurs. moo+ will output updates as each migration is reverted.++ test <migration name>: once you've created a migration, you might+ find it useful to test the migration to be sure that it is+ syntactically valid; the "test" command will apply the specified+ migration and revert it (if revert SQL is specified in the+ migration). It will perform both of these operations in a+ transaction and then issue a rollback.++ upgrade: this will apply all migrations in the migration store which+ have not yet been applied to the database. Each migration will be+ applied with its dependenciees in the correct order. All of the+ migrations will be applied together in a single transaction. By+ default, this transaction is committed; if you use the --test+ flag, the transaction will be rolled back, allowing you to test+ the entire upgrade process.++ upgrade-list: this will list the migrations that the "upgrade"+ command would apply if you were to run it. In other words, this+ will list all migrations which have not yet been applied to the+ database.
+ README view
@@ -0,0 +1,109 @@++dbmigrations+------------++This package contains a library and program for the creation,+management, and installation of schema updates (called "migrations")+for a relational database. In particular, this package lets the+migration author express explicit dependencies between migrations and+the management tool automatically installs or reverts migrations+accordingly, using transactions for safety.++This package operates on two logical entities:++ - The "backend", which is the relational database whose schema you+ want to manage.++ - The "migration store" (or simply "store"), which is the collection+ of schema changes you want to apply to the database. These+ migrations are expressed using plain text files collected together+ in a single directory, although the library is general enough to+ permit easy implementation of other storage backends for+ migrations.++Migration file format+---------------------++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:++ Description: (optional) a textual description of the migration++ Dependencies: (required, but may be empty) a whitespace-separated+ list of migration names on which the migration+ depends; these names are the migration filenames+ without the filename extension++ Created: The UTC date and time at which this migration was+ created++ Apply: The SQL necessary to apply this migration to the+ database++ 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 "#".++moo: the management tool+------------------------++This package includes one program, "moo". For information about moo's+usage and features, please see the file MOO.TXT.++Installation+------------++If you've obtained this package in source form and would like to+install it, you'll need the "cabal" program. To install this package,+run:++ cabal install++Getting the source+------------------++If you've obtained this package by some other means and would like to+get a copy of the source code, you can do so with darcs:++ darcs get http://repos.codevine.org/dbmigrations++For more information about the "darcs" revision control system, please+see:++ http://darcs.net/++Submitting patches+------------------++I'll gladly consider accepting patches to this package; please do not+hesitate to send them to me with "darcs send", or mail them to me+manually (see below). If you'd like to send me a patch, I'll be more+likely to accept it if you can follow these guidelines where+appropriate:++ - Keep patches small; a single patch should make a single logical+ change with minimal scope.++ - If possible, include tests with your patch.++ - If possible, include haddock with your patch.++Submitting bug reports and feedback+-----------------------------------++If you've found a bug or would like to provide any feedback on the+design, implementation, or behavior of this library or its programs,+please do not hesitate to contact me directly at++ drcygnus AT gmail DOT com++Enjoy!
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ dbmigrations.cabal view
@@ -0,0 +1,88 @@+Name: dbmigrations+Version: 0.1+Synopsis: An implementation of relational database "migrations"+Description: A library and program for the creation,+ management, and installation of schema updates+ (called /migrations/) for a relational database.+ In particular, this package lets the migration+ author express explicit dependencies between+ migrations and the management tool automatically+ installs or reverts migrations accordingly, using+ transactions for safety.++ This package is written to support any+ HDBC-supported database, although at present only+ PostgreSQL is fully supported.++ To get started, see the included 'README' and+ 'MOO.TXT' files and the usage output for the+ 'moo' command.++Category: Database+Author: Jonathan Daugherty <drcygnus@gmail.com>+Maintainer: Jonathan Daugherty <drcygnus@gmail.com>+Build-Type: Simple+License: BSD3+License-File: LICENSE+Cabal-Version: >= 1.2+Homepage: http://repos.codevine.org/dbmigrations/+Data-Files: README MOO.TXT++Flag testing+ Description: Build for testing+ Default: False++Flag store-manager+ Description: Build the experimental / incomplete store-manager program+ Default: False++Library+ Build-Depends:+ base >= 4 && < 5,+ HDBC,+ time >= 1.1 && < 1.2,+ random >= 1.0 && < 1.1,+ containers >= 0.2 && < 0.3,+ mtl >= 1.1 && < 1.2,+ parsec >= 2.1 && < 2.2,+ filepath >= 1.1 && < 1.2,+ directory >= 1.0 && < 1.2,+ fgl >= 5.4 && < 5.5,+ template-haskell++ Hs-Source-Dirs: src+ Exposed-Modules:+ Database.Schema.Migrations+ Database.Schema.Migrations.Dependencies+ Database.Schema.Migrations.Migration+ Database.Schema.Migrations.Filesystem+ Database.Schema.Migrations.Backend+ Database.Schema.Migrations.Backend.HDBC+ Database.Schema.Migrations.Store++Executable test+ Build-Depends:+ HDBC-postgresql,+ HUnit >= 1.2 && < 1.3,+ process >= 1.0 && < 1.1++ if !flag(testing)+ Buildable: False+ end+ Hs-Source-Dirs: src,test+ Main-is: TestDriver.hs++Executable moo+ Hs-Source-Dirs: src+ Main-is: Moo.hs++Executable store-manager+ Build-Depends:+ hscurses >= 1.3 && < 1.4++ if !flag(testing)+ Buildable: False+ end+ Hs-Source-Dirs: src+ Main-is: StoreManager.hs+ Ghc-options: -Werror
+ src/Database/Schema/Migrations.hs view
@@ -0,0 +1,103 @@+-- |This module provides a high-level interface for the rest of this+-- library.+module Database.Schema.Migrations+ ( createNewMigration+ , ensureBootstrappedBackend+ , migrationsToApply+ , migrationsToRevert+ , missingMigrations+ )+where++import qualified Data.Set as Set+import Data.Maybe ( catMaybes )++import Database.Schema.Migrations.Dependencies+ ( dependencies+ , reverseDependencies+ )+import qualified Database.Schema.Migrations.Backend as B+import qualified Database.Schema.Migrations.Store as S+import Database.Schema.Migrations.Migration+ ( Migration(..)+ , newMigration+ , MonadMigration+ )++-- |Given a 'B.Backend' and a 'S.MigrationMap', query the backend and+-- return a list of migration names which are available in the+-- 'S.MigrationMap' but which are not installed in the 'B.Backend'.+missingMigrations :: (B.Backend b m) => b -> S.StoreData -> m [String]+missingMigrations backend storeData = do+ let storeMigrationNames = map mId $ S.storeMigrations storeData+ backendMigrations <- B.getMigrations backend++ return $ Set.toList $ Set.difference+ (Set.fromList storeMigrationNames)+ (Set.fromList backendMigrations)++-- |Create a new migration and store it in the 'S.MigrationStore',+-- with some of its fields initially set to defaults.+createNewMigration :: (MonadMigration m, S.MigrationStore s m)+ => s -- ^ The 'S.MigrationStore' in which to create a new migration+ -> String -- ^ The name of the new migration to create+ -> [String] -- ^ The list of migration names on which the new migration should depend+ -> m (Either String Migration)+createNewMigration store name deps = do+ available <- S.getMigrations store+ case name `elem` available of+ True -> do+ fullPath <- S.fullMigrationName store name+ return $ Left $ "Migration " ++ (show fullPath) ++ " already exists"+ False -> do+ new <- newMigration name+ let newWithDefaults = new { mDesc = Just "(Description here.)"+ , mApply = "(Apply SQL here.)"+ , mRevert = Just "(Revert SQL here.)"+ , mDeps = deps+ }+ S.saveMigration store newWithDefaults+ return $ Right newWithDefaults++-- |Given a 'B.Backend', ensure that the backend is ready for use by+-- bootstrapping it. This entails installing the appropriate database+-- elements to track installed migrations. If the backend is already+-- bootstrapped, this has no effect.+ensureBootstrappedBackend :: (B.Backend b m) => b -> m ()+ensureBootstrappedBackend backend = do+ bsStatus <- B.isBootstrapped backend+ case bsStatus of+ True -> return ()+ False -> B.getBootstrapMigration backend >>= B.applyMigration backend++-- |Given a migration mapping computed from a MigrationStore, a+-- backend, and a migration to apply, return a list of migrations to+-- apply, in order.+migrationsToApply :: (B.Backend b m) => S.StoreData -> b+ -> Migration -> m [Migration]+migrationsToApply storeData backend migration = do+ let graph = S.storeDataGraph storeData++ allMissing <- missingMigrations backend storeData++ let deps = (dependencies graph $ mId migration) ++ [mId migration]+ namesToInstall = [ e | e <- deps, e `elem` allMissing ]+ loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToInstall++ return loadedMigrations++-- |Given a migration mapping computed from a MigrationStore, a+-- backend, and a migration to revert, return a list of migrations to+-- revert, in order.+migrationsToRevert :: (B.Backend b m) => S.StoreData -> b+ -> Migration -> m [Migration]+migrationsToRevert storeData backend migration = do+ let graph = S.storeDataGraph storeData++ allInstalled <- B.getMigrations backend++ let rDeps = (reverseDependencies graph $ mId migration) ++ [mId migration]+ namesToRevert = [ e | e <- rDeps, e `elem` allInstalled ]+ loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToRevert++ return loadedMigrations
+ src/Database/Schema/Migrations/Backend.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Database.Schema.Migrations.Backend+ ( Backend(..)+ )+where++import Database.Schema.Migrations.Migration+ ( Migration(..) )++-- |A Backend represents a database engine backend such as MySQL or+-- SQLite. A Backend supplies relatively low-level functions for+-- inspecting the backend's state, applying migrations, and reverting+-- migrations. A Backend also supplies the migration necessary to+-- "bootstrap" a backend so that it can track which migrations are+-- installed.+class (Monad m) => Backend b m where+ -- |The migration necessary to bootstrap a database with this+ -- connection interface. This might differ slightly from one+ -- backend to another.+ getBootstrapMigration :: b -> m Migration++ -- |Returns whether the backend has been bootstrapped. A backend+ -- has been bootstrapped if is capable of tracking which+ -- migrations have been installed; the "bootstrap migration"+ -- provided by getBootstrapMigration should suffice to bootstrap+ -- the backend.+ isBootstrapped :: b -> m Bool++ -- |Apply the specified migration on the backend. applyMigration+ -- does NOT assume control of the transaction, since it expects+ -- the transaction to (possibly) cover more than one+ -- applyMigration operation. The caller is expected to call+ -- commit at the appropriate time. If the application fails, the+ -- underlying SqlError is raised and a manual rollback may be+ -- necessary; for this, see withTransaction from HDBC.+ applyMigration :: b -> Migration -> m ()++ -- |Revert the specified migration from the backend and record+ -- this action in the table which tracks installed migrations.+ -- revertMigration does NOT assume control of the transaction,+ -- since it expects the transaction to (possibly) cover more than+ -- one revertMigration operation. The caller is expected to call+ -- commit at the appropriate time. If the revert fails, the+ -- underlying SqlError is raised and a manual rollback may be+ -- necessary; for this, see withTransaction from HDBC. If the+ -- specified migration does not supply a revert instruction, this+ -- has no effect other than bookkeeping.+ revertMigration :: b -> Migration -> m ()++ -- |Returns a list of installed migration names from the backend.+ getMigrations :: b -> m [String]
+ src/Database/Schema/Migrations/Backend/HDBC.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.Schema.Migrations.Backend.HDBC+ ()+where++import Database.HDBC ( quickQuery, fromSql, toSql, IConnection(getTables, run) )++import Database.Schema.Migrations.Backend+ ( Backend(..) )+import Database.Schema.Migrations.Migration+ ( Migration(..)+ , newMigration+ )++import Control.Applicative ( (<$>) )++migrationTableName :: String+migrationTableName = "installed_migrations"++createSql :: String+createSql = "CREATE TABLE " ++ migrationTableName ++ " (migration_id TEXT)"++revertSql :: String+revertSql = "DROP TABLE " ++ migrationTableName++-- |General Backend instance for all IO-driven HDBC connection+-- implementations. You can provide a connection-specific instance if+-- need be; this implementation is provided with the hope that you+-- won't /have/ to do that.+instance (IConnection conn) => Backend conn IO where+ isBootstrapped conn = elem migrationTableName <$> getTables conn++ getBootstrapMigration _ =+ do+ m <- newMigration "root"+ return $ m { mApply = createSql+ , mRevert = Just revertSql+ , mDesc = Just "Migration table installation"+ }++ applyMigration conn m = do+ run conn (mApply m) []+ run conn ("INSERT INTO " ++ migrationTableName +++ " (migration_id) VALUES (?)") [toSql $ mId m]+ return ()++ revertMigration conn m = do+ case mRevert m of+ Nothing -> return ()+ Just query -> run conn query [] >> return ()+ -- Remove migration from installed_migrations in either case.+ run conn ("DELETE FROM " ++ migrationTableName +++ " WHERE migration_id = ?") [toSql $ mId m]+ return ()++ getMigrations conn = do+ results <- quickQuery conn ("SELECT migration_id FROM " ++ migrationTableName) []+ return $ map (\(h:_) -> fromSql h) results
+ src/Database/Schema/Migrations/Dependencies.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TypeSynonymInstances #-}+-- |This module types and functions for representing a dependency+-- graph of arbitrary objects and functions for querying such graphs+-- to get dependency and reverse dependency information.+module Database.Schema.Migrations.Dependencies+ ( Dependable(..)+ , DependencyGraph(..)+ , mkDepGraph+ , dependencies+ , reverseDependencies+ )+where++import Data.Maybe ( fromJust )+import Data.Graph.Inductive.Graph ( Graph(..), nodes, edges, Node, suc, pre, lab )+import Data.Graph.Inductive.PatriciaTree ( Gr )++import Database.Schema.Migrations.CycleDetection ( hasCycle )++-- |'Dependable' objects supply a representation of their identifiers,+-- and a list of other objects upon which they depend.+class (Eq a, Ord a) => Dependable a where+ -- |The identifiers of the objects on which @a@ depends.+ depsOf :: a -> [String]+ -- |The identifier of a 'Dependable' object.+ depId :: a -> String++-- |A 'DependencyGraph' represents a collection of objects together+-- with a graph of their dependency relationships. This is intended+-- to be used with instances of 'Dependable'.+data DependencyGraph a = DG { depGraphObjectMap :: [(a, Int)]+ -- ^ A mapping of 'Dependable' objects to+ -- their graph vertex indices.+ , depGraphNameMap :: [(String, Int)]+ -- ^ A mapping of 'Dependable' object+ -- identifiers to their graph vertex+ -- indices.+ , depGraph :: Gr String String+ -- ^ A directed 'Gr' (graph) of the+ -- 'Dependable' objects' dependency+ -- relationships, with 'String' vertex and+ -- edge labels.+ }++instance (Eq a) => Eq (DependencyGraph a) where+ g1 == g2 = ((nodes $ depGraph g1) == (nodes $ depGraph g2) &&+ (edges $ depGraph g1) == (edges $ depGraph g2))++instance (Show a) => Show (DependencyGraph a) where+ show g = "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")"++-- XXX: provide details about detected cycles+-- |Build a dependency graph from a list of 'Dependable's. Return the+-- graph on success or return an error message if the graph cannot be+-- constructed (e.g., if the graph contains a cycle).+mkDepGraph :: (Dependable a) => [a] -> Either String (DependencyGraph a)+mkDepGraph objects = if hasCycle theGraph+ then Left "Invalid dependency graph; cycle detected"+ else Right $ DG { depGraphObjectMap = ids+ , depGraphNameMap = names+ , depGraph = theGraph+ }+ where+ theGraph = mkGraph n e+ n = [ (fromJust $ lookup o ids, depId o) | o <- objects ]+ e = [ ( fromJust $ lookup o ids+ , fromJust $ lookup d ids+ , depId o ++ " -> " ++ depId d) | o <- objects, d <- depsOf' o ]+ depsOf' o = map (\i -> fromJust $ lookup i objMap) $ depsOf o++ objMap = map (\o -> (depId o, o)) objects+ ids = zip objects [1..]+ names = map (\(o,i) -> (depId o, i)) ids++type NextNodesFunc = Gr String String -> Node -> [Node]++cleanLDups :: (Eq a) => [a] -> [a]+cleanLDups [] = []+cleanLDups [e] = [e]+cleanLDups (e:es) = if e `elem` es then (cleanLDups es) else (e:cleanLDups es)++-- |Given a dependency graph and an ID, return the IDs of objects that+-- the object depends on. IDs are returned with least direct+-- dependencies first (i.e., the apply order).+dependencies :: (Dependable d) => DependencyGraph d -> String -> [String]+dependencies g m = reverse $ cleanLDups $ dependenciesWith suc g m++-- |Given a dependency graph and an ID, return the IDs of objects that+-- depend on it. IDs are returned with least direct reverse+-- dependencies first (i.e., the revert order).+reverseDependencies :: (Dependable d) => DependencyGraph d -> String -> [String]+reverseDependencies g m = reverse $ cleanLDups $ dependenciesWith pre g m++dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> String -> [String]+dependenciesWith nextNodes dg@(DG _ nMap theGraph) name =+ let lookupId = fromJust $ lookup name nMap+ depNodes = nextNodes theGraph lookupId+ recurse theNodes = map (dependenciesWith nextNodes dg) theNodes+ getLabel node = fromJust $ lab theGraph node+ labels = map getLabel depNodes+ in labels ++ (concat $ recurse labels)
+ src/Database/Schema/Migrations/Filesystem.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE MultiParamTypeClasses #-}+-- |This module provides a type for interacting with a+-- filesystem-backed 'MigrationStore'.+module Database.Schema.Migrations.Filesystem+ ( FilesystemStore(..)+ , migrationFromFile+ )+where++import System.Directory ( getDirectoryContents, doesFileExist )+import System.FilePath ( (</>), takeExtension, dropExtension )++import Data.Time.Clock ( UTCTime )+import Data.Time () -- for UTCTime Show instance++import Control.Monad ( filterM )++import Text.ParserCombinators.Parsec ( parse )++import Database.Schema.Migrations.Migration+ ( Migration(..)+ , newMigration+ )+import Database.Schema.Migrations.Filesystem.Parse+import Database.Schema.Migrations.Filesystem.Serialize+import Database.Schema.Migrations.Store++type FieldProcessor = String -> Migration -> Maybe Migration++data FilesystemStore = FSStore { storePath :: FilePath }++filenameExtension :: String+filenameExtension = ".txt"++instance MigrationStore FilesystemStore IO where+ fullMigrationName s name =+ return $ storePath s </> name ++ filenameExtension++ loadMigration s theId = do+ result <- migrationFromFile s theId+ return $ case result of+ Left _ -> Nothing+ Right m -> Just m++ getMigrations s = do+ contents <- getDirectoryContents $ storePath s+ let migrationFilenames = [ f | f <- contents, isMigrationFilename f ]+ fullPaths = [ (f, storePath s </> f) | f <- migrationFilenames ]+ existing <- filterM (\(_, full) -> doesFileExist full) fullPaths+ return [ dropExtension short | (short, _) <- existing ]++ saveMigration s m = do+ filename <- fullMigrationName s $ mId m+ writeFile filename $ serializeMigration m++isMigrationFilename :: FilePath -> Bool+isMigrationFilename path = takeExtension path == filenameExtension++-- |Given a file path, read and parse the migration at the specified+-- path and, if successful, return the migration and its claimed+-- dependencies. Otherwise return a parsing error message.+migrationFromFile :: FilesystemStore -> String -> IO (Either String Migration)+migrationFromFile store name = do+ path <- fullMigrationName store name+ contents <- readFile 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)++missingFields :: FieldSet -> [FieldName]+missingFields fs =+ [ k | k <- requiredFields, not (k `elem` inputFieldNames) ]+ where+ inputFieldNames = [ n | (n, _) <- 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 m [] = Just m+migrationFromFields m ((name, value):rest) = do+ processor <- lookup name fieldProcessors+ newM <- processor value m+ migrationFromFields newM rest++requiredFields :: [FieldName]+requiredFields = [ "Created"+ , "Apply"+ , "Depends"+ ]++fieldProcessors :: [(FieldName, FieldProcessor)]+fieldProcessors = [ ("Created", setTimestamp )+ , ("Description", setDescription )+ , ("Apply", setApply )+ , ("Revert", setRevert )+ , ("Depends", setDepends )+ ]++setTimestamp :: FieldProcessor+setTimestamp value m = do+ ts <- case readTimestamp value of+ [(t, _)] -> return t+ _ -> fail "expected one valid parse"+ return $ m { mTimestamp = ts }++readTimestamp :: String -> [(UTCTime, String)]+readTimestamp = reads++setDescription :: FieldProcessor+setDescription desc m = Just $ m { mDesc = Just desc }++setApply :: FieldProcessor+setApply apply m = Just $ m { mApply = apply }++setRevert :: FieldProcessor+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 }
+ src/Database/Schema/Migrations/Migration.hs view
@@ -0,0 +1,41 @@+module Database.Schema.Migrations.Migration+ ( Migration(..)+ , MonadMigration(..)+ , newMigration+ )+where++import Database.Schema.Migrations.Dependencies++import Data.Time () -- for UTCTime Show instance+import qualified Data.Time.Clock as Clock++data Migration = Migration { mTimestamp :: Clock.UTCTime+ , mId :: String+ , mDesc :: Maybe String+ , mApply :: String+ , mRevert :: Maybe String+ , mDeps :: [String]+ }+ deriving (Eq, Show, Ord)++instance Dependable Migration where+ depsOf = mDeps+ depId = mId++class (Monad m) => MonadMigration m where+ getCurrentTime :: m Clock.UTCTime++instance MonadMigration IO where+ getCurrentTime = Clock.getCurrentTime++newMigration :: (MonadMigration m) => String -> m Migration+newMigration theId = do+ curTime <- getCurrentTime+ return $ Migration { mTimestamp = curTime+ , mId = theId+ , mDesc = Nothing+ , mApply = ""+ , mRevert = Nothing+ , mDeps = []+ }
+ src/Database/Schema/Migrations/Store.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE MultiParamTypeClasses #-}+-- |This module provides an abstraction for a /migration store/, a+-- facility in which 'Migration's can be stored and from which they+-- can be loaded. This module also provides functions for taking+-- 'Migration's from a store and converting them into the appropriate+-- intermediate types for use with the rest of this library.+module Database.Schema.Migrations.Store+ ( MigrationStore(..)+ , MapValidationError(..)+ , StoreData(..)+ , MigrationMap++ -- * High-level Store API+ , loadMigrations+ , storeMigrations+ , storeLookup++ -- * Miscellaneous Functions+ , depGraphFromMapping+ )+where++import Data.Maybe ( catMaybes, isJust )+import Control.Monad ( mzero )+import Control.Applicative ( (<$>) )+import qualified Data.Map as Map++import Database.Schema.Migrations.Migration+ ( Migration(..)+ )+import Database.Schema.Migrations.Dependencies+ ( DependencyGraph(..)+ , mkDepGraph+ , depsOf+ )++-- |A mapping from migration name to 'Migration'. This is exported+-- for testing purposes, but you'll want to interface with this+-- through the encapsulating 'StoreData' type.+type MigrationMap = Map.Map String Migration++data StoreData = StoreData { storeDataMapping :: MigrationMap+ , storeDataGraph :: DependencyGraph Migration+ }++-- |A type class for types which represent a storage facility (and a+-- monad context in which to operate on the store). A MigrationStore+-- is a facility in which new migrations can be created, and from+-- which existing migrations can be loaded.+class (Monad m) => MigrationStore s m where+ -- |Load a migration from the store.+ loadMigration :: s -> String -> m (Maybe Migration)++ -- |Save a migration to the store.+ saveMigration :: s -> Migration -> m ()++ -- |Return a list of all available migrations' names.+ getMigrations :: s -> m [String]++ -- |Return the full representation of a given migration name;+ -- mostly for filesystem stores, where the full representation+ -- includes the store path.+ fullMigrationName :: s -> String -> m String+ fullMigrationName _ name = return name++-- |A type for types of validation errors for migration maps.+data MapValidationError = DependencyReferenceError String String+ -- ^ A migration claims a dependency on a+ -- migration that does not exist.+ | DependencyGraphError String+ -- ^ An error was encountered when+ -- constructing the dependency graph for+ -- this store.++instance Show MapValidationError where+ show (DependencyReferenceError from to) =+ "Migration " ++ (show from) ++ " references nonexistent dependency " ++ show to+ show (DependencyGraphError msg) =+ "There was an error constructing the dependency graph: " ++ msg++-- |A convenience function for extracting the list of 'Migration's+-- extant in the specified 'StoreData'.+storeMigrations :: StoreData -> [Migration]+storeMigrations storeData =+ Map.elems $ storeDataMapping storeData++-- |A convenience function for looking up a 'Migration' by name in the+-- specified 'StoreData'.+storeLookup :: StoreData -> String -> Maybe Migration+storeLookup storeData migrationName =+ Map.lookup migrationName $ storeDataMapping storeData++-- |Load migrations from the specified 'MigrationStore', validate the+-- loaded migrations, and return errors or a 'MigrationMap' on+-- success. Generally speaking, this will be the first thing you+-- should call once you have constructed a 'MigrationStore'.+loadMigrations :: (MigrationStore s m) => s -> m (Either [MapValidationError] StoreData)+loadMigrations store = do+ migrations <- getMigrations store+ loaded <- mapM (\name -> loadMigration store name) migrations+ let mMap = Map.fromList $ [ (mId e, e) | e <- catMaybes $ loaded ]+ validationErrors = validateMigrationMap mMap++ case null validationErrors of+ False -> return $ Left validationErrors+ True -> do+ -- Construct a dependency graph and, if that succeeds, return+ -- StoreData.+ case depGraphFromMapping mMap of+ Left e -> return $ Left [DependencyGraphError e]+ Right gr -> return $ Right StoreData { storeDataMapping = mMap+ , storeDataGraph = gr+ }++-- |Validate a migration map. Returns zero or more validation errors.+validateMigrationMap :: MigrationMap -> [MapValidationError]+validateMigrationMap mMap = do+ validateSingleMigration mMap =<< snd <$> Map.toList mMap++validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError]+validateSingleMigration mMap m = do+ depId <- depsOf m+ if isJust $ Map.lookup depId mMap then+ mzero else+ return $ DependencyReferenceError (mId m) depId++-- |Create a 'DependencyGraph' from a 'MigrationMap'; returns Left if+-- the dependency graph cannot be constructed (e.g., due to a+-- dependency cycle) or Right on success. Generally speaking, you+-- won't want to use this directly; use 'loadMigrations' instead.+depGraphFromMapping :: MigrationMap -> Either String (DependencyGraph Migration)+depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping
+ src/Moo.hs view
@@ -0,0 +1,561 @@+{-# 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 ( 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+ )+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+ }++newtype DbConnDescriptor = DbConnDescriptor String++-- 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"] [] []+ "Apply the specified migration and its dependencies"+ applyCommand+ , Command "revert" ["migration_name"] [] []+ "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 to be installed during \+ \an upgrade"+ upgradeListCommand+ ]++-- The values of DBM_DATABASE_TYPE and their corresponding connection+-- factory functions.+databaseTypes :: [(String, String -> IO AnyIConnection)]+databaseTypes = [ ("postgresql", fmap AnyIConnection . connectPostgreSQL)+ ]++-- 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+ 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 -> IO [Migration]+apply m storeData backend = 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+ 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'++applyCommand :: CommandHandler+applyCommand storeData = do+ required <- asks appRequiredArgs+ let [migrationId] = required++ withConnection $ \(AnyIConnection conn) -> do+ ensureBootstrappedBackend conn >> commit conn+ m <- lookupMigration storeData migrationId+ apply m storeData conn+ commit conn+ putStrLn "Successfully applied migrations."++revertCommand :: CommandHandler+revertCommand storeData = do+ required <- asks appRequiredArgs+ let [migrationId] = required++ withConnection $ \(AnyIConnection conn) -> do+ ensureBootstrappedBackend conn >> commit conn+ m <- lookupMigration storeData migrationId+ revert m storeData conn+ commit conn+ putStrLn "Successfully reverted migrations."++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+ 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++ putStrLn $ "Usage: " ++ progName ++ " <command> [args]"+ putStrLn "Environment:"+ putStrLn $ " " ++ envDatabaseName ++ ": database connection string"+ putStrLn $ " " ++ envDatabaseType ++ ": database type, one of " +++ (intercalate "," $ map fst databaseTypes)+ putStrLn $ " " ++ envStoreName ++ ": path to migration store"+ putStrLn "Commands:"+ forM_ commands $ \command -> do+ putStrLn $ " " ++ usageString command+ putStrLn $ " " ++ cDescription command+ putStrLn ""++ putStrLn "Options:"+ forM_ optionMap $ \(name, option) -> do+ putStrLn $ " " ++ name ++ ": " ++ optionUsage option+ 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++ -- 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++ let (required,optional) = splitAt (length $ cRequired command) args+ store = FSStore { storePath = storePathStr }++ if (length args) < (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+ 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+ }+ (runReaderT (cHandler command $ storeData) st) `catchSql` reportSqlError
+ src/StoreManager.hs view
@@ -0,0 +1,272 @@++module Main where++import Control.Exception+import Control.Monad.State+import Data.Maybe ( fromJust, isNothing )+import qualified Data.Map as Map+import System.Environment (getArgs, getProgName)+import System.Exit (exitFailure)++import UI.HSCurses.Widgets+import qualified UI.HSCurses.Curses as Curses+import qualified UI.HSCurses.CursesHelper as CursesH++import Database.Schema.Migrations.Filesystem+import Database.Schema.Migrations.Store++title :: String+title = "Migration Manager"++help :: String+help = "q:quit"++data MMState = MMState+ { mmStoreData :: StoreData+ , mmStatus :: String+ , mmStyles :: [CursesH.CursesStyle]+ , mmStorePath :: FilePath+ }++type MM = StateT MMState IO++type ToplineWidget = TextWidget+type HelpLineWidget = TextWidget+type StatusBarWidget = TableWidget+type MigrationListWidget = TableWidget++data MainWidget = MainWidget+ { toplineWidget :: ToplineWidget+ , helplineWidget :: HelpLineWidget+ , statusbarWidget :: StatusBarWidget+ , migrationListWidget :: MigrationListWidget+ }++instance Widget MainWidget where+ draw pos sz hint w = draw pos sz hint (mkRealMainWidget (Just sz) w)+ minSize w = minSize (mkRealMainWidget Nothing w)++runMM :: FilePath -> StoreData -> [CursesH.CursesStyle] -> MM a -> IO a+runMM sp storeData cstyles mm =+ evalStateT mm (MMState { mmStoreData = storeData+ , mmStyles = cstyles+ , mmStatus = sp ++ " loaded."+ , mmStorePath = sp+ })++getSize :: MM (Int, Int)+getSize = liftIO $ Curses.scrSize++styles :: [CursesH.Style]+styles = [ CursesH.defaultStyle+ , CursesH.AttributeStyle [CursesH.Bold] CursesH.GreenF CursesH.DarkBlueB+ ]++nthStyle :: Int -> MM CursesH.CursesStyle+nthStyle n =+ do cs <- gets mmStyles+ return $ cs !! n++defStyle :: MM CursesH.CursesStyle+defStyle = nthStyle 0++lineStyle :: MM CursesH.CursesStyle+lineStyle = nthStyle 1++lineDrawingStyle :: MM DrawingStyle+lineDrawingStyle = do+ s <- lineStyle+ return $ mkDrawingStyle s++lineOptions :: MM TextWidgetOptions+lineOptions = do+ sz <- getSize+ ds <- lineDrawingStyle+ return $ TWOptions { twopt_size = TWSizeFixed (1, getWidth sz)+ , twopt_style = ds+ , twopt_halign = AlignLeft+ }++mkToplineWidget :: MM ToplineWidget+mkToplineWidget = do+ opts <- lineOptions+ return $ newTextWidget (opts { twopt_halign = AlignCenter }) title++mkHelpLineWidget :: MM HelpLineWidget+mkHelpLineWidget = do+ opts <- lineOptions+ return $ newTextWidget opts help++-- We need to insert a dummy widget at the lower-right corner of the+-- window, i.e. at the lower-right corner of the message+-- line. Otherwise, an error occurs because drawing a character to+-- this position moves the cursor to the next line, which doesn't+-- exist.+mkStatusBarWidget :: MM StatusBarWidget+mkStatusBarWidget = do+ sz <- getSize+ msg <- gets mmStatus+ let width = getWidth sz+ opts = TWOptions { twopt_size = TWSizeFixed (1, width - 1)+ , twopt_style = defaultDrawingStyle+ , twopt_halign = AlignLeft+ }+ tw = newTextWidget opts msg+ row = [TableCell tw, TableCell $ EmptyWidget (1,1)]+ tabOpts = defaultTBWOptions { tbwopt_minSize = (1, width) }+ return $ newTableWidget tabOpts [row]++-- nlines = height of status line + height of help line + height of+-- top line+nlines :: Int+nlines = 3++migrationListHeight :: (Int, Int) -> Int+migrationListHeight (h, _) = h - nlines++migrationListOptions :: MM TableWidgetOptions+migrationListOptions = do+ sz <- getSize+ return $ TBWOptions { tbwopt_fillCol = Nothing+ , tbwopt_fillRow = None+ , tbwopt_activeCols = [0]+ , tbwopt_minSize = (migrationListHeight sz, getWidth sz)+ }++mkMigrationListWidget :: MM MigrationListWidget+mkMigrationListWidget = do+ storeData <- gets mmStoreData+ sz <- getSize+ let rows = map (migrationRow $ getWidth sz) (Map.keys $ storeDataMapping storeData)+ opts <- migrationListOptions+ return $ newTableWidget opts rows+ where migrationRow w s = [TableCell $ newTextWidget+ (defaultTWOptions { twopt_size = TWSizeFixed (1, w) }) s]++validPos :: Pos -> TableWidget -> Bool+validPos pos w = (getWidth pos) `elem` (tbwopt_activeCols $ tbw_options w) &&+ (getHeight pos) < (length $ tbw_rows w) &&+ (getHeight pos) >= 0 &&+ (getWidth pos) >= 0++moveUp :: TableWidget -> TableWidget+moveUp orig =+ if isNothing (tbw_pos orig) then orig+ else+ let oldPos = fromJust $ tbw_pos orig+ newPos = ((getHeight $ oldPos) - 1, getWidth oldPos)+ in if validPos newPos orig+ then orig { tbw_pos = Just newPos }+ else orig++moveDown :: TableWidget -> TableWidget+moveDown orig =+ if isNothing (tbw_pos orig) then orig+ else+ let oldPos = fromJust $ tbw_pos orig+ newPos = ((getHeight $ oldPos) + 1, getWidth oldPos)+ in if validPos newPos orig+ then orig { tbw_pos = Just newPos }+ else orig++mkMainWidget :: MM MainWidget+mkMainWidget = do+ tlw <- mkToplineWidget+ clw <- mkMigrationListWidget+ blw <- mkHelpLineWidget+ msglw <- mkStatusBarWidget+ return $ MainWidget tlw blw msglw clw++mkRealMainWidget :: Maybe Size -> MainWidget -> TableWidget+mkRealMainWidget msz w =+ let cells = [ TableCell $ toplineWidget w+ , TableCell $ migrationListWidget w+ , TableCell $ helplineWidget w+ , TableCell $ statusbarWidget w ]+ rows = map singletonRow cells+ opts = case msz of+ Nothing -> defaultTBWOptions+ Just sz -> defaultTBWOptions { tbwopt_minSize = sz }+ in newTableWidget opts rows++updateStateDependentWidgets :: MainWidget -> MM MainWidget+updateStateDependentWidgets w = do+ statusbar <- mkStatusBarWidget -- update the message line with the+ -- state's status+ return $ w { statusbarWidget = statusbar }++updateStatus :: String -> MM ()+updateStatus msg = do+ st <- get+ put st { mmStatus = msg }++move :: Direction -> MainWidget -> MM MainWidget+move dir w = do+ let listWidget = case dir of+ DirUp -> moveUp orig+ DirDown -> moveDown orig+ _ -> orig+ orig = migrationListWidget w+ w' <- updateStateDependentWidgets w+ return $ w' { migrationListWidget = listWidget }++resize :: Widget w => MM w -> MM ()+resize f = do+ liftIO $ do Curses.endWin+ Curses.resetParams+ Curses.cursSet Curses.CursorInvisible+ Curses.refresh+ w <- f+ redraw w++redraw :: Widget w => w -> MM ()+redraw w = do+ sz <- getSize+ liftIO $ do draw (0, 0) sz DHNormal w+ Curses.refresh++eventloop :: MainWidget -> MM ()+eventloop w = do+ k <- CursesH.getKey (resize mkMainWidget)+ case k of+ Curses.KeyChar 'q' -> return ()+ Curses.KeyUp -> process $ move DirUp w+ Curses.KeyDown -> process $ move DirDown w+ _ -> eventloop w+ where process f = do+ w' <- f+ redraw w'+ eventloop w'++mmMain :: MM ()+mmMain = do+ w <- mkMainWidget+ redraw w+ eventloop w++main :: IO ()+main = do+ args <- getArgs+ let theStorePath = args !! 0+ storeData <-+ if length args /= 1+ then do p <- getProgName+ putStrLn ("Usage: " ++ p ++ " <store-path>")+ exitFailure+ else do+ let store = FSStore { storePath = theStorePath }+ result <- loadMigrations store+ case result of+ Left es -> do+ putStrLn "There were errors in the migration store:"+ forM_ es $ \err -> do+ putStrLn $ " " ++ show err+ exitFailure+ Right theStoreData -> return theStoreData++ runCurses theStorePath storeData `finally` CursesH.end+ where runCurses sp storeData = do+ CursesH.start+ cstyles <- CursesH.convertStyles styles+ Curses.cursSet Curses.CursorInvisible+ runMM sp storeData cstyles mmMain
+ test/TestDriver.hs view
@@ -0,0 +1,83 @@+module Main where+import Prelude hiding ( catch )+import Test.HUnit+import System.Exit+import System.Process ( system )+import System.IO ( stderr )++import qualified BackendTest+import qualified DependencyTest+import qualified MigrationsTest+import qualified FilesystemSerializeTest+import qualified FilesystemParseTest+import qualified FilesystemTest+import qualified CycleDetectionTest++import Control.Monad ( forM )+import Control.Exception ( finally, catch, SomeException )++import Database.HDBC ( IConnection(disconnect) )+--import Database.HDBC.Sqlite3 ( connectSqlite3 )+import qualified Database.HDBC.PostgreSQL as PostgreSQL++loadTests :: IO [Test]+loadTests = do++-- sqliteConn <- connectSqlite3 ":memory:"+ pgConn <- setupPostgresDb++ let backends = [ -- ("Sqlite", BackendTest.tests sqliteConn)+ ("PostgreSQL", BackendTest.tests pgConn `finally`+ (disconnect pgConn >> teardownPostgresDb))+ ]++ backendTests <- forM backends $ \(name, testAct) -> do+ return $ (name ++ " backend tests") ~: test testAct++ ioTests <- sequence [ do fspTests <- FilesystemParseTest.tests+ return $ "Filesystem Parsing" ~: test fspTests+ , do fsTests <- FilesystemTest.tests+ return $ "Filesystem general" ~: test fsTests+ ]+ return $ concat [ backendTests+ , ioTests+ , DependencyTest.tests+ , FilesystemSerializeTest.tests+ , MigrationsTest.tests+ , CycleDetectionTest.tests+ ]++tempPgDatabase :: String+tempPgDatabase = "dbmigrations_test"++ignoreException :: SomeException -> IO ()+ignoreException _ = return ()++setupPostgresDb :: IO PostgreSQL.Connection+setupPostgresDb = do+ teardownPostgresDb `catch` ignoreException++ -- create database+ status <- system $ "createdb " ++ tempPgDatabase+ case status of+ ExitSuccess -> return ()+ ExitFailure _ -> error $ "Failed to create PostgreSQL database " ++ (show tempPgDatabase)++ -- return test db connection+ PostgreSQL.connectPostgreSQL $ "dbname=" ++ tempPgDatabase++teardownPostgresDb :: IO ()+teardownPostgresDb = do+ -- create database+ status <- system $ "dropdb " ++ tempPgDatabase ++ " 2>/dev/null"+ case status of+ ExitSuccess -> return ()+ ExitFailure _ -> error $ "Failed to drop PostgreSQL database " ++ (show tempPgDatabase)++main :: IO ()+main = do+ tests <- loadTests+ (testResults, _) <- runTestText (putTextToHandle stderr False) $ test tests+ if errors testResults + failures testResults > 0+ then exitFailure+ else exitSuccess