diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/MOO.TXT b/MOO.TXT new file mode 100644 --- /dev/null +++ b/MOO.TXT @@ -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 : 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 : 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 : 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 : 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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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! diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/dbmigrations.cabal b/dbmigrations.cabal new file mode 100644 --- /dev/null +++ b/dbmigrations.cabal @@ -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 +Maintainer: Jonathan Daugherty +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 diff --git a/src/Database/Schema/Migrations.hs b/src/Database/Schema/Migrations.hs new file mode 100644 --- /dev/null +++ b/src/Database/Schema/Migrations.hs @@ -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 diff --git a/src/Database/Schema/Migrations/Backend.hs b/src/Database/Schema/Migrations/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Database/Schema/Migrations/Backend.hs @@ -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] diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs new file mode 100644 --- /dev/null +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -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 diff --git a/src/Database/Schema/Migrations/Dependencies.hs b/src/Database/Schema/Migrations/Dependencies.hs new file mode 100644 --- /dev/null +++ b/src/Database/Schema/Migrations/Dependencies.hs @@ -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) diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs new file mode 100644 --- /dev/null +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -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 } diff --git a/src/Database/Schema/Migrations/Migration.hs b/src/Database/Schema/Migrations/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Database/Schema/Migrations/Migration.hs @@ -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 = [] + } diff --git a/src/Database/Schema/Migrations/Store.hs b/src/Database/Schema/Migrations/Store.hs new file mode 100644 --- /dev/null +++ b/src/Database/Schema/Migrations/Store.hs @@ -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 diff --git a/src/Moo.hs b/src/Moo.hs new file mode 100644 --- /dev/null +++ b/src/Moo.hs @@ -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 ++ " [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 diff --git a/src/StoreManager.hs b/src/StoreManager.hs new file mode 100644 --- /dev/null +++ b/src/StoreManager.hs @@ -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 ++ " ") + 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 diff --git a/test/TestDriver.hs b/test/TestDriver.hs new file mode 100644 --- /dev/null +++ b/test/TestDriver.hs @@ -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