module Database.Migrate.Main (defaultMain, defaultMain') where
import Control.Monad
import Control.Monad.Trans.Either
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Maybe
import qualified Data.Text as T
import Data.Maybe
import Database.Migrate.Data
import Database.Migrate.Kernel
import Database.Migrate.Loader
import Database.Migrate.PostgreSQL
import qualified Database.PostgreSQL.Simple as PG
import System.Console.CmdArgs.Explicit
import System.Directory
import System.FilePath
import System.Exit
import System.Environment (getArgs)
import System.IO
ignore :: Arg Arguments
ignore = flagArg (\_ a -> Right a) ""
e :: String
e = ""
usage = [
"usage: db migrate [-v|--verbose] [-d|--dry-run]"
, " db up [-v|--verbose] [-d|--dry-run]"
, " db down [-v|--verbose] [-d|--dry-run]"
, " db apply [-v|--verbose] [-d|--dry-run]"
, " db -h|--help"
, " db -V|--version"
]
globalflags :: [Flag Arguments]
globalflags = [
flagNone [ "h", "help" ] (\a -> a { adbmode = HelpMode }) e
, flagNone [ "V", "version" ] (\a -> a { adbmode = VersionMode }) e
]
connectflags :: [Flag Arguments]
connectflags = [
flagNone [ "v", "verbose" ] (\a -> a { averbose = True }) e
, flagNone [ "d", "dry-run" ] (\a -> a { adry = True }) e
]
versionflag = (flagArg (\v a -> Right $ a { aversion = Just v }) "VERSION")
cmdmodes :: String -> Arguments -> Mode Arguments
cmdmodes cmd initial =
modes cmd initial "" [
mode "migrate" (initial { adbmode = MigrateMode }) "" ignore connectflags
, mode "up" (initial { adbmode = UpMode }) "" versionflag connectflags
, mode "down" (initial { adbmode = DownMode }) "" versionflag connectflags
, mode "apply" (initial { adbmode = ApplyMode }) "" versionflag connectflags
, mode "help" (initial { adbmode = HelpMode }) "" ignore []
, mode "version" (initial { adbmode = VersionMode }) "" ignore []
]
data DbMode =
HelpMode
| VersionMode
| MigrateMode
| UpMode
| DownMode
| ApplyMode
deriving (Eq, Show)
data Arguments = Arguments {
adbmode :: DbMode
, adry :: Bool
, averbose :: Bool
, ascripts :: String
, aversion :: Maybe String
} deriving (Eq, Show)
defaultArguments cwd = Arguments {
adbmode = HelpMode
, adry = False
, averbose = False
, ascripts = cwd </> "migrations"
, aversion = Nothing
}
defaultMain :: Migrations -> MigrateDatabase IO c -> IO c -> IO ()
defaultMain migrationstore db connector = getArgs >>= defaultMain' migrationstore db connector
defaultMain' :: Migrations -> MigrateDatabase IO c -> IO c -> [String] -> IO ()
defaultMain' migrationstore db connector args =
getCurrentDirectory >>= \cwd ->
case process ((cmdmodes "migrate" (defaultArguments cwd)) {modeGroupFlags = toGroup $ globalflags} ) args of
Left x -> hPutStrLn stderr x >> exitFailure
Right x -> run migrationstore db connector x
run :: Migrations -> MigrateDatabase IO c -> IO c -> Arguments -> IO ()
run migrationstore db' connector args =
let db = if adry args then dryrun db' else db'
in case adbmode args of
HelpMode -> mapM_ putStrLn usage
VersionMode -> putStrLn $ "migrate 0.1.1"
MigrateMode -> connector >>= \c -> (executeMigrate migrationstore c $ migrate db) >>= print
UpMode -> connector >>= \c -> (executeMigrate migrationstore c $ upmode db) >>= print
DownMode -> connector >>= \c -> (executeMigrate migrationstore c $ downmode db) >>= print
ApplyMode -> connector >>= \c -> (executeMigrate migrationstore c $ applymode db) >>= print
bomb failwith =
putStrLn failwith >> exitFailure
upmode :: MigrateDatabase m c -> Migrate c m ()
upmode = undefined
downmode :: MigrateDatabase m c -> Migrate c m ()
downmode = undefined
applymode :: MigrateDatabase m c -> Migrate c m ()
applymode = undefined