diff --git a/database-migrate.cabal b/database-migrate.cabal index 83d9c21..546be3d 100644 --- a/database-migrate.cabal +++ b/database-migrate.cabal @@ -9,7 +9,7 @@ Synopsis: Database versioning and migration Category: Database Homepage: https://github.com/markhibberd/database-migrate Bug-reports: https://github.com/markhibberd/database-migrate/issues -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-Type: Simple Description: A database versioning and migration library. @@ -29,7 +29,7 @@ Flag small_base Library Build-Depends: - base >= 3 && < 5 + base >= 3 && < 5 , text >= 0.11 && < 0.12 , directory >= 1.0 && < 2.0 , filepath >= 1.0 && < 2.0 @@ -56,3 +56,12 @@ Library OverloadedStrings +Executable migrate + Main-Is: main.hs + Hs-Source-Dirs: src + Ghc-Options: -Wall -O2 + Build-Depends: + base >= 3 && < 5 + , database-migrate + , cmdargs >= 0.9.3 && < 1.0.0 + diff --git a/src/Database/Migrate/Core.hs b/src/Database/Migrate/Core.hs index 9a4b1ec..39b4d0c 100644 --- a/src/Database/Migrate/Core.hs +++ b/src/Database/Migrate/Core.hs @@ -13,6 +13,8 @@ import System.FilePath import System.Directory import System.IO +import Debug.Trace + type MigrationId = Text type Ddl = Text @@ -44,7 +46,7 @@ pick ms ids = let available = foldr (S.insert . migration) S.empty ms installed = S.fromList ids torun = S.difference available installed - in filter (\m -> S.member (migration m) torun) ms + in trace ("/xx/ " ++ show (fmap migration ms) ++ " /yy/ " ++ show torun) (filter (\m -> S.member (migration m) torun) ms) latest :: MigrateDatabase m c => c -> [Migration] -> MigrationResultT m [MigrationId] latest c migrations = diff --git a/src/Database/Migrate/PostgreSQL.hs b/src/Database/Migrate/PostgreSQL.hs index 65a2a95..d25c990 100644 --- a/src/Database/Migrate/PostgreSQL.hs +++ b/src/Database/Migrate/PostgreSQL.hs @@ -12,6 +12,8 @@ import Data.String (IsString(..)) import Database.PostgreSQL.Simple import Database.Migrate.Core +import Debug.Trace + instance MigrateDatabase IO Connection where initialize c = void $ execute_ c "CREATE TABLE IF NOT EXISTS MIGRATION_INFO (MIGRATION VARCHAR(50) PRIMARY KEY)" runMigrations = runall @@ -23,11 +25,12 @@ record conn mid = void $ execute conn "INSERT INTO MIGRATION_INFO VALUES (?)" (O runall :: Connection -> (Migration -> Ddl) -> [Migration] -> MigrationResultT IO [MigrationId] runall c f ms = liftIO (begin c) >> + liftIO (putTraceMsg ("running: " ++ show (fmap migration ms))) >> (foldM (\rs m -> EitherT $ do e <- runEitherT (saferun c f m) case e of - Left emsg -> rollback c >> (return . Left $ Context (reverse rs) (migration m) emsg True) + Left emsg -> liftIO (putTraceMsg $ "rolling back: " ++ show emsg) >> rollback c >> (return . Left $ Context (reverse rs) (migration m) emsg True) Right r -> return . Right $ r:rs) [] ms) >>= \result -> liftIO (commit c) >> return (reverse result) saferun :: Connection -> (Migration -> Ddl) -> Migration -> EitherT Text IO MigrationId diff --git a/src/main.hs b/src/main.hs new file mode 100644 index 0000000..3239d14 --- /dev/null +++ b/src/main.hs @@ -0,0 +1,44 @@ +import qualified Paths_database_migrate as Program (version) + +import Control.Monad (mapM_) +import Data.Version (showVersion) +import System.Console.CmdArgs.Explicit +import System.Console.CmdArgs.Text +import System.Exit + +usage :: [String] +usage = [ + "usage: migrate ..." + , " migrate -h|--help" + , " migrate -v|--version" + ] + +data Arguments = Arguments { + help :: Bool + , version :: Bool + } deriving (Eq, Show) + +defaultArguments :: Arguments +defaultArguments = Arguments False False + +ignore :: Arg Arguments +ignore = flagArg (\_ a -> Right a) "" + +migratemode :: Mode Arguments +migratemode = + mode "migrate" defaultArguments "" ignore [ + flagNone [ "h", "help" ] (\a -> a { help = True }) "print help and exit" + , flagNone [ "V", "version" ] (\a -> a { version = True }) "print version and exit" + ] + +migrate :: IO () +migrate = undefined + +run :: Arguments -> IO () +run args + | help args = mapM_ putStrLn usage + | version args = putStrLn $ "migrate " ++ showVersion Program.version + | otherwise = migrate + +main :: IO () +main = processArgs migratemode >>= run