{-# LANGUAGE OverloadedStrings #-}
module Moo.Main
    ( mainWithParameters
    , ExecutableParameters (..)
    , Configuration (..)
    , Args
    , usage
    , usageSpecific
    , procArgs
    )
where

import  Control.Monad.Reader (forM_, runReaderT, when)
import  Database.HDBC (SqlError, catchSql, seErrorMsg)
import  Prelude  hiding (lookup)
import  Data.Text (Text)
import  Data.String.Conversions (cs)
import  System.Environment (getProgName)
import  System.Exit (ExitCode (ExitFailure), exitWith)

import  Database.Schema.Migrations.Filesystem (filesystemStore, FilesystemStoreSettings(..))
import  Database.Schema.Migrations.Store
import  Moo.CommandInterface
import  Moo.Core

type Args = [String]

usage :: IO a
usage :: IO a
usage = do
  String
progName <- IO String
getProgName

  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Usage: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
progName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <command> [args]"
  String -> IO ()
putStrLn String
"Environment:"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
envDatabaseName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": database connection string"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
envStoreName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": path to migration store"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
envLinearMigrations String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": whether to use linear migrations (defaults to False)"
  String -> IO ()
putStrLn String
"Commands:"
  [Command] -> (Command -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Command]
commands ((Command -> IO ()) -> IO ()) -> (Command -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Command
command -> do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Command -> String
usageString Command
command
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Command -> String
_cDescription Command
command
          String -> IO ()
putStrLn String
""

  String -> IO ()
putStrLn String
commandOptionUsage
  ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)

usageSpecific :: Command -> IO a
usageSpecific :: Command -> IO a
usageSpecific Command
command = do
  String
pn <- IO String
getProgName
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Usage: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Command -> String
usageString Command
command
  ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)

procArgs :: Args -> IO (Command, CommandOptions, [String])
procArgs :: Args -> IO (Command, CommandOptions, Args)
procArgs Args
args = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Args -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Args
args) IO ()
forall a. IO a
usage

  Command
command <- case String -> Maybe Command
findCommand (String -> Maybe Command) -> String -> Maybe Command
forall a b. (a -> b) -> a -> b
$ Args -> String
forall a. [a] -> a
head Args
args of
               Maybe Command
Nothing -> IO Command
forall a. IO a
usage
               Just Command
c -> Command -> IO Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
c

  (CommandOptions
opts, Args
required) <- Args -> IO (CommandOptions, Args)
getCommandArgs (Args -> IO (CommandOptions, Args))
-> Args -> IO (CommandOptions, Args)
forall a b. (a -> b) -> a -> b
$ Args -> Args
forall a. [a] -> [a]
tail Args
args

  (Command, CommandOptions, Args)
-> IO (Command, CommandOptions, Args)
forall (m :: * -> *) a. Monad m => a -> m a
return (Command
command, CommandOptions
opts, Args
required)

mainWithParameters :: Args -> ExecutableParameters -> IO ()
mainWithParameters :: Args -> ExecutableParameters -> IO ()
mainWithParameters Args
args ExecutableParameters
parameters = do
  (Command
command, CommandOptions
opts, Args
required) <- Args -> IO (Command, CommandOptions, Args)
procArgs Args
args

  let storePathStr :: String
storePathStr = ExecutableParameters -> String
_parametersMigrationStorePath ExecutableParameters
parameters
      store :: MigrationStore
store = FilesystemStoreSettings -> MigrationStore
filesystemStore (FilesystemStoreSettings -> MigrationStore)
-> FilesystemStoreSettings -> MigrationStore
forall a b. (a -> b) -> a -> b
$ FSStore :: String -> FilesystemStoreSettings
FSStore { storePath :: String
storePath = String
storePathStr }
      linear :: Bool
linear = ExecutableParameters -> Bool
_parametersLinearMigrations ExecutableParameters
parameters

  if Args -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Args
required Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Args -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ( Command -> Args
_cRequired Command
command) then
      Command -> IO ()
forall a. Command -> IO a
usageSpecific Command
command else
      do
        Either [MapValidationError] StoreData
loadedStoreData <- MigrationStore -> IO (Either [MapValidationError] StoreData)
loadMigrations MigrationStore
store
        case Either [MapValidationError] StoreData
loadedStoreData of
          Left [MapValidationError]
es -> do
            String -> IO ()
putStrLn String
"There were errors in the migration store:"
            [MapValidationError] -> (MapValidationError -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [MapValidationError]
es ((MapValidationError -> IO ()) -> IO ())
-> (MapValidationError -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \MapValidationError
err -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MapValidationError -> String
forall a. Show a => a -> String
show MapValidationError
err
          Right StoreData
storeData -> do
            let st :: AppState
st = AppState :: CommandOptions
-> Command
-> [Text]
-> [Text]
-> Backend
-> MigrationStore
-> StoreData
-> Bool
-> Bool
-> AppState
AppState { _appOptions :: CommandOptions
_appOptions = CommandOptions
opts
                              , _appCommand :: Command
_appCommand = Command
command
                              , _appRequiredArgs :: [Text]
_appRequiredArgs = (String -> Text) -> Args -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Args
required
                              , _appOptionalArgs :: [Text]
_appOptionalArgs = [Text
"" :: Text]
                              , _appBackend :: Backend
_appBackend = ExecutableParameters -> Backend
_parametersBackend ExecutableParameters
parameters
                              , _appStore :: MigrationStore
_appStore = MigrationStore
store
                              , _appStoreData :: StoreData
_appStoreData = StoreData
storeData
                              , _appLinearMigrations :: Bool
_appLinearMigrations = Bool
linear
                              , _appTimestampFilenames :: Bool
_appTimestampFilenames =
                                  ExecutableParameters -> Bool
_parametersTimestampFilenames ExecutableParameters
parameters
                              }
            ReaderT AppState IO () -> AppState -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Command -> CommandHandler
_cHandler Command
command StoreData
storeData) AppState
st IO () -> (SqlError -> IO ()) -> IO ()
forall a. IO a -> (SqlError -> IO a) -> IO a
`catchSql` SqlError -> IO ()
forall a. SqlError -> IO a
reportSqlError

reportSqlError :: SqlError -> IO a
reportSqlError :: SqlError -> IO a
reportSqlError SqlError
e = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"A database error occurred: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SqlError -> String
seErrorMsg SqlError
e
  ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)