started cli

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
+

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 =

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

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