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

-- |The monad in which the application runs.
type AppT a = ReaderT AppState IO a

-- |The type of actions that are invoked to handle specific commands
type CommandHandler = StoreData -> AppT ()

-- |Application state which can be accessed by any command handler.
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)]

-- |Intermediate type used during config loading.
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

-- |Loading the configuration from a file or having it specified via environment
-- |variables results in a value of type Configuration.
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

-- |A value of type ExecutableParameters is what a moo executable (moo-postgresql,
-- |moo-mysql, etc.) pass to the core package when they want to execute a
-- |command.
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)

-- |Setters for fields of 'LoadConfig'.
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 }


-- | @f .= v@ invokes f only if v is 'Just'
(.=) :: (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

-- |It's just @flip '<*>'@
(&) :: (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

-- |Loads config file (falling back to default one if not specified) and then
-- overrides configuration with an environment.
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
    }

-- |Converts @Just "on"@ and @Just "true"@ (case insensitive) to @True@,
-- anything else to @False@.
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

-- |CommandOptions are those options that can be specified at the command
-- prompt to modify the behavior of a command.
data CommandOptions = CommandOptions { CommandOptions -> Maybe String
_configFilePath :: Maybe String
                                     , CommandOptions -> Bool
_test           :: Bool
                                     , CommandOptions -> Bool
_noAsk          :: Bool
                                     }

-- |A command has a name, a number of required arguments' labels, a
-- number of optional arguments' labels, and an action to invoke.
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"