{-|
Module      : Headroom.AppConfig
Description : Application configuration
Copyright   : (c) 2019-2020 Vaclav Svejcar
License     : BSD-3
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

This module adds support for loading and parsing application configuration.
Such configuration can be loaded either from /YAML/ config file, or from command
line arguments. Provided 'Semigroup' and 'Monoid' instances allows to merge
multiple loaded configurations into one.
-}
{-# 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


-- | Application configuration, loaded either from configuration file or command
-- line options.
data AppConfig = AppConfig
  { AppConfig -> RunMode
acRunMode       :: RunMode           -- ^ selected mode of /Run/ command
  , AppConfig -> [FilePath]
acSourcePaths   :: [FilePath]        -- ^ paths to source code files
  , AppConfig -> [FilePath]
acTemplatePaths :: [FilePath]        -- ^ paths to template files
  , AppConfig -> HashMap Text Text
acVariables     :: HashMap Text Text -- ^ variables to replace
  }
  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)

-- | Support for reading configuration from /YAML/.
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

-- | Loads and parses application configuration from given file.
loadAppConfig :: MonadIO m
              => FilePath    -- ^ path to configuration file
              -> m AppConfig -- ^ parsed configuration
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

-- | Rewrites all file paths in 'AppConfig' to be relative to given file path.
makePathsRelativeTo :: FilePath  -- ^ file path to use
                    -> AppConfig -- ^ input application configuration
                    -> AppConfig -- ^ result with relativized file paths
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
</>)

-- | Parses application configuration from given raw input.
parseAppConfig :: MonadThrow m
               => B.ByteString -- ^ raw input to parse
               -> m AppConfig  -- ^ parsed application configuration
parseAppConfig :: ByteString -> m AppConfig
parseAppConfig = ByteString -> m AppConfig
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Y.decodeThrow

-- | Parses variables from raw input in @key=value@ format.
--
-- >>> parseVariables ["key1=value1"]
-- fromList [("key1","value1")]
parseVariables :: MonadThrow m
               => [Text]                -- ^ list of raw variables
               -> m (HashMap Text Text) -- ^ parsed variables
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

-- | Validates whether given 'AppConfig' contains valid data.
validateAppConfig :: MonadThrow m
                  => AppConfig   -- ^ application config to validate
                  -> m AppConfig -- ^ validated application config (or errors)
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