{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Headroom.AppConfig
( AppConfig(..)
, loadAppConfig
, makePathsRelativeTo
, parseAppConfig
, parseVariables
, validateAppConfig
)
where
import Control.Lens
import Data.Aeson ( FromJSON(parseJSON)
, genericParseJSON
)
import Data.Validation
import qualified Data.Yaml as Y
import Headroom.Types ( AppConfigError(..)
, HeadroomError(..)
, RunMode(..)
)
import Headroom.Types.Utils ( customOptions )
import RIO
import qualified RIO.ByteString as B
import RIO.FilePath ( takeDirectory
, (</>)
)
import qualified RIO.HashMap as HM
import qualified RIO.Text as T
data AppConfig = AppConfig
{ AppConfig -> RunMode
acRunMode :: RunMode
, AppConfig -> [FilePath]
acSourcePaths :: [FilePath]
, AppConfig -> [FilePath]
acTemplatePaths :: [FilePath]
, AppConfig -> HashMap Text Text
acVariables :: HashMap Text Text
}
deriving (AppConfig -> AppConfig -> Bool
(AppConfig -> AppConfig -> Bool)
-> (AppConfig -> AppConfig -> Bool) -> Eq AppConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AppConfig -> AppConfig -> Bool
$c/= :: AppConfig -> AppConfig -> Bool
== :: AppConfig -> AppConfig -> Bool
$c== :: AppConfig -> AppConfig -> Bool
Eq, (forall x. AppConfig -> Rep AppConfig x)
-> (forall x. Rep AppConfig x -> AppConfig) -> Generic AppConfig
forall x. Rep AppConfig x -> AppConfig
forall x. AppConfig -> Rep AppConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AppConfig x -> AppConfig
$cfrom :: forall x. AppConfig -> Rep AppConfig x
Generic, Int -> AppConfig -> ShowS
[AppConfig] -> ShowS
AppConfig -> FilePath
(Int -> AppConfig -> ShowS)
-> (AppConfig -> FilePath)
-> ([AppConfig] -> ShowS)
-> Show AppConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [AppConfig] -> ShowS
$cshowList :: [AppConfig] -> ShowS
show :: AppConfig -> FilePath
$cshow :: AppConfig -> FilePath
showsPrec :: Int -> AppConfig -> ShowS
$cshowsPrec :: Int -> AppConfig -> ShowS
Show)
instance FromJSON AppConfig where
parseJSON :: Value -> Parser AppConfig
parseJSON = Options -> Value -> Parser AppConfig
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
customOptions
instance Semigroup AppConfig where
x :: AppConfig
x <> :: AppConfig -> AppConfig -> AppConfig
<> y :: AppConfig
y = RunMode
-> [FilePath] -> [FilePath] -> HashMap Text Text -> AppConfig
AppConfig (AppConfig -> RunMode
acRunMode AppConfig
x)
(AppConfig -> [FilePath]
acSourcePaths AppConfig
x [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> AppConfig -> [FilePath]
acSourcePaths AppConfig
y)
(AppConfig -> [FilePath]
acTemplatePaths AppConfig
x [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> AppConfig -> [FilePath]
acTemplatePaths AppConfig
y)
(AppConfig -> HashMap Text Text
acVariables AppConfig
x HashMap Text Text -> HashMap Text Text -> HashMap Text Text
forall a. Semigroup a => a -> a -> a
<> AppConfig -> HashMap Text Text
acVariables AppConfig
y)
instance Monoid AppConfig where
mempty :: AppConfig
mempty = RunMode
-> [FilePath] -> [FilePath] -> HashMap Text Text -> AppConfig
AppConfig RunMode
Add [] [] HashMap Text Text
forall k v. HashMap k v
HM.empty
loadAppConfig :: MonadIO m
=> FilePath
-> m AppConfig
loadAppConfig :: FilePath -> m AppConfig
loadAppConfig path :: FilePath
path = do
AppConfig
appConfig <- IO AppConfig -> m AppConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppConfig -> m AppConfig) -> IO AppConfig -> m AppConfig
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
B.readFile FilePath
path IO ByteString -> (ByteString -> IO AppConfig) -> IO AppConfig
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO AppConfig
forall (m :: * -> *). MonadThrow m => ByteString -> m AppConfig
parseAppConfig
AppConfig -> m AppConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (AppConfig -> m AppConfig) -> AppConfig -> m AppConfig
forall a b. (a -> b) -> a -> b
$ FilePath -> AppConfig -> AppConfig
makePathsRelativeTo (ShowS
takeDirectory FilePath
path) AppConfig
appConfig
makePathsRelativeTo :: FilePath
-> AppConfig
-> AppConfig
makePathsRelativeTo :: FilePath -> AppConfig -> AppConfig
makePathsRelativeTo root :: FilePath
root appConfig :: AppConfig
appConfig = AppConfig
appConfig
{ acSourcePaths :: [FilePath]
acSourcePaths = [FilePath] -> [FilePath]
processPaths ([FilePath] -> [FilePath])
-> (AppConfig -> [FilePath]) -> AppConfig -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppConfig -> [FilePath]
acSourcePaths (AppConfig -> [FilePath]) -> AppConfig -> [FilePath]
forall a b. (a -> b) -> a -> b
$ AppConfig
appConfig
, acTemplatePaths :: [FilePath]
acTemplatePaths = [FilePath] -> [FilePath]
processPaths ([FilePath] -> [FilePath])
-> (AppConfig -> [FilePath]) -> AppConfig -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppConfig -> [FilePath]
acTemplatePaths (AppConfig -> [FilePath]) -> AppConfig -> [FilePath]
forall a b. (a -> b) -> a -> b
$ AppConfig
appConfig
}
where processPaths :: [FilePath] -> [FilePath]
processPaths = ShowS -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
root FilePath -> ShowS
</>)
parseAppConfig :: MonadThrow m
=> B.ByteString
-> m AppConfig
parseAppConfig :: ByteString -> m AppConfig
parseAppConfig = ByteString -> m AppConfig
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Y.decodeThrow
parseVariables :: MonadThrow m
=> [Text]
-> m (HashMap Text Text)
parseVariables :: [Text] -> m (HashMap Text Text)
parseVariables variables :: [Text]
variables = ([(Text, Text)] -> HashMap Text Text)
-> m [(Text, Text)] -> m (HashMap Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ((Text -> m (Text, Text)) -> [Text] -> m [(Text, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> m (Text, Text)
forall (m :: * -> *). MonadThrow m => Text -> m (Text, Text)
parse [Text]
variables)
where
parse :: Text -> m (Text, Text)
parse input :: Text
input = case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '=') Text
input of
[key :: Text
key, value :: Text
value] -> (Text, Text) -> m (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
key, Text
value)
_ -> HeadroomError -> m (Text, Text)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeadroomError -> m (Text, Text))
-> HeadroomError -> m (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> HeadroomError
InvalidVariable Text
input
validateAppConfig :: MonadThrow m
=> AppConfig
-> m AppConfig
validateAppConfig :: AppConfig -> m AppConfig
validateAppConfig appConfig :: AppConfig
appConfig = case Validation [AppConfigError] AppConfig
checked of
Success ac' :: AppConfig
ac' -> AppConfig -> m AppConfig
forall (m :: * -> *) a. Monad m => a -> m a
return AppConfig
ac'
Failure errors :: [AppConfigError]
errors -> HeadroomError -> m AppConfig
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeadroomError -> m AppConfig) -> HeadroomError -> m AppConfig
forall a b. (a -> b) -> a -> b
$ [AppConfigError] -> HeadroomError
InvalidAppConfig [AppConfigError]
errors
where
checked :: Validation [AppConfigError] AppConfig
checked = AppConfig
appConfig AppConfig
-> Validation [AppConfigError] AppConfig
-> Validation [AppConfigError] AppConfig
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Validation [AppConfigError] AppConfig
checkSourcePaths Validation [AppConfigError] AppConfig
-> Validation [AppConfigError] AppConfig
-> Validation [AppConfigError] AppConfig
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Validation [AppConfigError] AppConfig
checkTemplatePaths
checkSourcePaths :: Validation [AppConfigError] AppConfig
checkSourcePaths = if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AppConfig -> [FilePath]
acSourcePaths AppConfig
appConfig)
then Tagged [AppConfigError] (Identity [AppConfigError])
-> Tagged
(Validation [AppConfigError] AppConfig)
(Identity (Validation [AppConfigError] AppConfig))
forall (f :: * -> * -> *) e1 a e2.
Validate f =>
Prism (f e1 a) (f e2 a) e1 e2
_Failure (Tagged [AppConfigError] (Identity [AppConfigError])
-> Tagged
(Validation [AppConfigError] AppConfig)
(Identity (Validation [AppConfigError] AppConfig)))
-> [AppConfigError] -> Validation [AppConfigError] AppConfig
forall t b. AReview t b -> b -> t
# [AppConfigError
EmptySourcePaths]
else Tagged AppConfig (Identity AppConfig)
-> Tagged
(Validation [AppConfigError] AppConfig)
(Identity (Validation [AppConfigError] AppConfig))
forall (f :: * -> * -> *) e a b.
Validate f =>
Prism (f e a) (f e b) a b
_Success (Tagged AppConfig (Identity AppConfig)
-> Tagged
(Validation [AppConfigError] AppConfig)
(Identity (Validation [AppConfigError] AppConfig)))
-> AppConfig -> Validation [AppConfigError] AppConfig
forall t b. AReview t b -> b -> t
# AppConfig
appConfig
checkTemplatePaths :: Validation [AppConfigError] AppConfig
checkTemplatePaths = if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AppConfig -> [FilePath]
acTemplatePaths AppConfig
appConfig)
then Tagged [AppConfigError] (Identity [AppConfigError])
-> Tagged
(Validation [AppConfigError] AppConfig)
(Identity (Validation [AppConfigError] AppConfig))
forall (f :: * -> * -> *) e1 a e2.
Validate f =>
Prism (f e1 a) (f e2 a) e1 e2
_Failure (Tagged [AppConfigError] (Identity [AppConfigError])
-> Tagged
(Validation [AppConfigError] AppConfig)
(Identity (Validation [AppConfigError] AppConfig)))
-> [AppConfigError] -> Validation [AppConfigError] AppConfig
forall t b. AReview t b -> b -> t
# [AppConfigError
EmptyTemplatePaths]
else Tagged AppConfig (Identity AppConfig)
-> Tagged
(Validation [AppConfigError] AppConfig)
(Identity (Validation [AppConfigError] AppConfig))
forall (f :: * -> * -> *) e a b.
Validate f =>
Prism (f e a) (f e b) a b
_Success (Tagged AppConfig (Identity AppConfig)
-> Tagged
(Validation [AppConfigError] AppConfig)
(Identity (Validation [AppConfigError] AppConfig)))
-> AppConfig -> Validation [AppConfigError] AppConfig
forall t b. AReview t b -> b -> t
# AppConfig
appConfig