{-# 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)