module Moo.Core
( AppT
, CommandHandler
, CommandOptions (..)
, Command (..)
, AppState (..)
, Configuration (..)
, makeParameters
, ExecutableParameters (..)
, envDatabaseName
, envLinearMigrations
, envStoreName
, loadConfiguration) where
import Control.Applicative
import Control.Monad.Reader (ReaderT)
import qualified Data.Configurator as C
import Data.Configurator.Types (Config, Configured)
import qualified Data.Text as T
import Data.Char (toLower)
import System.Environment (getEnvironment)
import Data.Maybe (fromMaybe)
import Database.Schema.Migrations.Store (MigrationStore, StoreData)
import Database.Schema.Migrations.Backend
type AppT a = ReaderT AppState IO a
type CommandHandler = StoreData -> AppT ()
data AppState = AppState { _appOptions :: CommandOptions
, _appCommand :: Command
, _appRequiredArgs :: [String]
, _appOptionalArgs :: [String]
, _appBackend :: Backend
, _appStore :: MigrationStore
, _appStoreData :: StoreData
, _appLinearMigrations :: Bool
, _appTimestampFilenames :: Bool
}
type ShellEnvironment = [(String, String)]
data LoadConfig = LoadConfig
{ _lcConnectionString :: Maybe String
, _lcMigrationStorePath :: Maybe FilePath
, _lcLinearMigrations :: Maybe Bool
, _lcTimestampFilenames :: Maybe Bool
} deriving Show
data Configuration = Configuration
{ _connectionString :: String
, _migrationStorePath :: FilePath
, _linearMigrations :: Bool
, _timestampFilenames :: Bool
} deriving Show
data ExecutableParameters = ExecutableParameters
{ _parametersBackend :: Backend
, _parametersMigrationStorePath :: FilePath
, _parametersLinearMigrations :: Bool
, _parametersTimestampFilenames :: Bool
} deriving Show
defConfigFile :: String
defConfigFile = "moo.cfg"
newLoadConfig :: LoadConfig
newLoadConfig = LoadConfig Nothing Nothing Nothing Nothing
validateLoadConfig :: LoadConfig -> Either String Configuration
validateLoadConfig (LoadConfig Nothing _ _ _) =
Left "Invalid configuration: connection string not specified"
validateLoadConfig (LoadConfig _ Nothing _ _) =
Left "Invalid configuration: migration store path not specified"
validateLoadConfig (LoadConfig (Just cs) (Just msp) lm ts) =
Right $ Configuration cs msp (fromMaybe False lm) (fromMaybe False ts)
lcConnectionString, lcMigrationStorePath
:: LoadConfig -> Maybe String -> LoadConfig
lcConnectionString c v = c { _lcConnectionString = v }
lcMigrationStorePath c v = c { _lcMigrationStorePath = v }
lcLinearMigrations :: LoadConfig -> Maybe Bool -> LoadConfig
lcLinearMigrations c v = c { _lcLinearMigrations = v }
lcTimestampFilenames :: LoadConfig -> Maybe Bool -> LoadConfig
lcTimestampFilenames c v = c { _lcTimestampFilenames = v }
(.=) :: (Monad m) => (a -> Maybe b -> a) -> m (Maybe b) -> m (a -> a)
(.=) f v' = do
v <- v'
return $ case v of
Just _ -> flip f v
_ -> id
(&) :: (Applicative m) => m a -> m (a -> b) -> m b
(&) = flip (<*>)
infixr 3 .=
infixl 2 &
applyEnvironment :: ShellEnvironment -> LoadConfig -> IO LoadConfig
applyEnvironment env lc =
return lc & lcConnectionString .= f envDatabaseName
& lcMigrationStorePath .= f envStoreName
& lcLinearMigrations .= readFlag <$> f envLinearMigrations
& lcTimestampFilenames .= readFlag <$> f envTimestampFilenames
where f n = return $ lookup n env
applyConfigFile :: Config -> LoadConfig -> IO LoadConfig
applyConfigFile cfg lc =
return lc & lcConnectionString .= f envDatabaseName
& lcMigrationStorePath .= f envStoreName
& lcLinearMigrations .= f envLinearMigrations
& lcTimestampFilenames .= f envTimestampFilenames
where
f :: Configured a => String -> IO (Maybe a)
f = C.lookup cfg . T.pack
loadConfiguration :: Maybe FilePath -> IO (Either String Configuration)
loadConfiguration pth = do
file <- maybe (C.load [C.Optional defConfigFile])
(\p -> C.load [C.Required p]) pth
env <- getEnvironment
cfg <- applyConfigFile file newLoadConfig >>= applyEnvironment env
return $ validateLoadConfig cfg
makeParameters :: Configuration -> Backend -> ExecutableParameters
makeParameters conf backend =
ExecutableParameters
{ _parametersBackend = backend
, _parametersMigrationStorePath = _migrationStorePath conf
, _parametersLinearMigrations = _linearMigrations conf
, _parametersTimestampFilenames = _timestampFilenames conf
}
readFlag :: Maybe String -> Maybe Bool
readFlag Nothing = Nothing
readFlag (Just v) = go $ map toLower v
where
go "on" = Just True
go "true" = Just True
go "off" = Just False
go "false" = Just False
go _ = Nothing
data CommandOptions = CommandOptions { _configFilePath :: Maybe String
, _test :: Bool
, _noAsk :: Bool
}
data Command = Command { _cName :: String
, _cRequired :: [String]
, _cOptional :: [String]
, _cAllowedOptions :: [String]
, _cDescription :: String
, _cHandler :: CommandHandler
}
envDatabaseName :: String
envDatabaseName = "DBM_DATABASE"
envStoreName :: String
envStoreName = "DBM_MIGRATION_STORE"
envLinearMigrations :: String
envLinearMigrations = "DBM_LINEAR_MIGRATIONS"
envTimestampFilenames :: String
envTimestampFilenames = "DBM_TIMESTAMP_FILENAMES"