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