{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

{-|
Module      : Headroom.Configuration
Description : Configuration handling (loading, parsing, validating)
Copyright   : (c) 2019-2020 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

This module provides logic for working with the cofiguration data types.
Headroom uses the
<https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67 partial options monoid>
pattern for the configuration, where the 'Configuration' is the data type for
total configuration and 'PartialConfiguration' for the partial one.
-}

module Headroom.Configuration
  ( -- * Loading & Parsing Configuration
    loadConfiguration
  , parseConfiguration
  , parseVariables
    -- * Processing Partial Configuration
  , makeConfiguration
  , makeHeadersConfig
  , makeHeaderConfig
  )
where

import           Data.Monoid                    ( Last(..) )
import qualified Data.Yaml                     as Y
import           Headroom.Types                 ( ApplicationError(..)
                                                , Configuration(..)
                                                , ConfigurationError(..)
                                                , FileType(..)
                                                , HeaderConfig(..)
                                                , HeadersConfig(..)
                                                , PartialConfiguration(..)
                                                , PartialHeaderConfig(..)
                                                , PartialHeadersConfig(..)
                                                )
import           RIO
import qualified RIO.ByteString                as B
import qualified RIO.HashMap                   as HM
import qualified RIO.Text                      as T



-- | Loads and parses application configuration from given /YAML/ file.
loadConfiguration :: MonadIO m
                  => FilePath               -- ^ path to /YAML/ configuration file
                  -> m PartialConfiguration -- ^ parsed configuration
loadConfiguration :: FilePath -> m PartialConfiguration
loadConfiguration path :: FilePath
path = IO PartialConfiguration -> m PartialConfiguration
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PartialConfiguration -> m PartialConfiguration)
-> IO PartialConfiguration -> m PartialConfiguration
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 PartialConfiguration)
-> IO PartialConfiguration
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO PartialConfiguration
forall (m :: * -> *).
MonadThrow m =>
ByteString -> m PartialConfiguration
parseConfiguration


-- | Parses application configuration from given raw input in /YAML/ format.
parseConfiguration :: MonadThrow m
                   => B.ByteString           -- ^ raw input to parse
                   -> m PartialConfiguration -- ^ parsed application configuration
parseConfiguration :: ByteString -> m PartialConfiguration
parseConfiguration = ByteString -> m PartialConfiguration
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 (f :: * -> *). MonadThrow f => Text -> f (Text, Text)
parse [Text]
variables)
 where
  parse :: Text -> f (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) -> f (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
key, Text
value)
    _            -> ApplicationError -> f (Text, Text)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ApplicationError -> f (Text, Text))
-> ApplicationError -> f (Text, Text)
forall a b. (a -> b) -> a -> b
$ ConfigurationError -> ApplicationError
ConfigurationError (Text -> ConfigurationError
InvalidVariable Text
input)


-- | Makes full 'Configuration' from provided 'PartialConfiguration' (if valid).
makeConfiguration :: MonadThrow m
                  => PartialConfiguration -- ^ source 'PartialConfiguration'
                  -> m Configuration      -- ^ full 'Configuration'
makeConfiguration :: PartialConfiguration -> m Configuration
makeConfiguration PartialConfiguration {..} = do
  RunMode
cRunMode        <- ConfigurationError -> Last RunMode -> m RunMode
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError ConfigurationError
NoRunMode Last RunMode
pcRunMode
  [FilePath]
cSourcePaths    <- ConfigurationError -> Last [FilePath] -> m [FilePath]
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError ConfigurationError
NoSourcePaths Last [FilePath]
pcSourcePaths
  [Text]
cExcludedPaths  <- ConfigurationError -> Last [Text] -> m [Text]
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError ConfigurationError
NoExcludedPaths Last [Text]
pcExcludedPaths
  [FilePath]
cTemplatePaths  <- ConfigurationError -> Last [FilePath] -> m [FilePath]
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError ConfigurationError
NoTemplatePaths Last [FilePath]
pcTemplatePaths
  HashMap Text Text
cVariables      <- ConfigurationError
-> Last (HashMap Text Text) -> m (HashMap Text Text)
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError ConfigurationError
NoVariables Last (HashMap Text Text)
pcVariables
  HeadersConfig
cLicenseHeaders <- PartialHeadersConfig -> m HeadersConfig
forall (m :: * -> *).
MonadThrow m =>
PartialHeadersConfig -> m HeadersConfig
makeHeadersConfig PartialHeadersConfig
pcLicenseHeaders
  Configuration -> m Configuration
forall (f :: * -> *) a. Applicative f => a -> f a
pure $WConfiguration :: RunMode
-> [FilePath]
-> [Text]
-> [FilePath]
-> HashMap Text Text
-> HeadersConfig
-> Configuration
Configuration { .. }


-- | Makes full 'HeadersConfig' from provided 'PartialHeadersConfig' (if valid).
makeHeadersConfig :: MonadThrow m
                  => PartialHeadersConfig -- ^ source 'PartialHeadersConfig'
                  -> m HeadersConfig      -- ^ full 'HeadersConfig'
makeHeadersConfig :: PartialHeadersConfig -> m HeadersConfig
makeHeadersConfig PartialHeadersConfig {..} = do
  HeaderConfig
hscC       <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
C PartialHeaderConfig
phscC
  HeaderConfig
hscCpp     <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
CPP PartialHeaderConfig
phscCpp
  HeaderConfig
hscCss     <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
CSS PartialHeaderConfig
phscCss
  HeaderConfig
hscHaskell <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
Haskell PartialHeaderConfig
phscHaskell
  HeaderConfig
hscHtml    <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
HTML PartialHeaderConfig
phscHtml
  HeaderConfig
hscJava    <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
Java PartialHeaderConfig
phscJava
  HeaderConfig
hscJs      <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
JS PartialHeaderConfig
phscJs
  HeaderConfig
hscRust    <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
Rust PartialHeaderConfig
phscRust
  HeaderConfig
hscScala   <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
Scala PartialHeaderConfig
phscScala
  HeaderConfig
hscShell   <- FileType -> PartialHeaderConfig -> m HeaderConfig
forall (m :: * -> *).
MonadThrow m =>
FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig FileType
Shell PartialHeaderConfig
phscShell
  HeadersConfig -> m HeadersConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure $WHeadersConfig :: HeaderConfig
-> HeaderConfig
-> HeaderConfig
-> HeaderConfig
-> HeaderConfig
-> HeaderConfig
-> HeaderConfig
-> HeaderConfig
-> HeaderConfig
-> HeaderConfig
-> HeadersConfig
HeadersConfig { .. }


-- | Makes full 'HeaderConfig' from provided 'PartialHeaderConfig' (if valid).
makeHeaderConfig :: MonadThrow m
                 => FileType             -- ^ determines for which file type this configuration is
                 -> PartialHeaderConfig  -- ^ source 'PartialHeaderConfig'
                 -> m HeaderConfig       -- ^ full 'HeaderConfig'
makeHeaderConfig :: FileType -> PartialHeaderConfig -> m HeaderConfig
makeHeaderConfig fileType :: FileType
fileType PartialHeaderConfig {..} = do
  [Text]
hcFileExtensions <- ConfigurationError -> Last [Text] -> m [Text]
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError (FileType -> ConfigurationError
NoFileExtensions FileType
fileType) Last [Text]
phcFileExtensions
  Int
hcMarginAfter    <- ConfigurationError -> Last Int -> m Int
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError (FileType -> ConfigurationError
NoMarginAfter FileType
fileType) Last Int
phcMarginAfter
  Int
hcMarginBefore   <- ConfigurationError -> Last Int -> m Int
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError (FileType -> ConfigurationError
NoMarginBefore FileType
fileType) Last Int
phcMarginBefore
  [Text]
hcPutAfter       <- ConfigurationError -> Last [Text] -> m [Text]
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError (FileType -> ConfigurationError
NoPutAfter FileType
fileType) Last [Text]
phcPutAfter
  [Text]
hcPutBefore      <- ConfigurationError -> Last [Text] -> m [Text]
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError (FileType -> ConfigurationError
NoPutBefore FileType
fileType) Last [Text]
phcPutBefore
  HeaderSyntax
hcHeaderSyntax   <- ConfigurationError -> Last HeaderSyntax -> m HeaderSyntax
forall (m :: * -> *) a.
MonadThrow m =>
ConfigurationError -> Last a -> m a
lastOrError (FileType -> ConfigurationError
NoHeaderSyntax FileType
fileType) Last HeaderSyntax
phcHeaderSyntax
  HeaderConfig -> m HeaderConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure $WHeaderConfig :: [Text]
-> Int -> Int -> [Text] -> [Text] -> HeaderSyntax -> HeaderConfig
HeaderConfig { .. }


lastOrError :: MonadThrow m => ConfigurationError -> Last a -> m a
lastOrError :: ConfigurationError -> Last a -> m a
lastOrError err :: ConfigurationError
err (Last x :: Maybe a
x) = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ApplicationError -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ApplicationError -> m a) -> ApplicationError -> m a
forall a b. (a -> b) -> a -> b
$ ConfigurationError -> ApplicationError
ConfigurationError ConfigurationError
err) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
x