{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

-- |
-- Module: Configuration.Utils.Internal.ConfigFileReader
-- Description: Internal Tools for Parsing Configuration Files
-- Copyright: Copyright © 2015 PivotCloud, Inc.
-- License: MIT
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--
module Configuration.Utils.Internal.ConfigFileReader
(
  parseConfigFiles
, readConfigFile
, ConfigFileFormat(..)

-- * Local Config Files
, loadLocal

#ifdef REMOTE_CONFIGS
-- * Remote Config Files
, isRemote
, loadRemote
, yamlMimeType
, jsonMimeType
, contentType
, requestHeaders
#endif
) where

import Configuration.Utils.ConfigFile
import Configuration.Utils.Internal
import Configuration.Utils.Validation

import Control.Applicative
import Control.DeepSeq (NFData)
import Control.Monad
import Control.Monad.Error.Class
import Control.Monad.IO.Class

import Data.Bifunctor
import qualified Data.ByteString.Char8 as B8
import Data.Monoid.Unicode
import qualified Data.Text as T
import Data.Typeable
import qualified Data.Yaml as Yaml

import GHC.Generics

import Prelude hiding (any, concatMap, mapM_)
import Prelude.Unicode

#ifdef REMOTE_CONFIGS
import Configuration.Utils.Internal.HttpsCertPolicy

import Control.Exception.Enclosed
import Control.Monad.Trans.Control

import qualified Data.ByteString.Lazy as LB
import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import Data.String
import qualified Data.Text.IO as T

import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types.Header as HTTP

import System.IO
#endif

-- -------------------------------------------------------------------------- --
-- Tools for parsing configuration files

#ifdef REMOTE_CONFIGS
type ConfigFileParser m =
    ( Functor m
    , Applicative m
    , MonadIO m
    , MonadBaseControl IO m
    , MonadError T.Text m
    )
#else
type ConfigFileParser m =
    ( Functor m
    , Applicative m
    , MonadIO m
    , MonadError T.Text m
    )
#endif

parseConfigFiles
    ∷ (ConfigFileParser m, FromJSON (a → a))
    ⇒ ConfigFilesConfig
    → a
        -- ^ default configuration value
    → [ConfigFile]
        -- ^ list of configuration file paths
    → m a
parseConfigFiles :: ConfigFilesConfig -> a -> [ConfigFile] -> m a
parseConfigFiles ConfigFilesConfig
conf = (a -> ConfigFile -> m a) -> a -> [ConfigFile] -> m a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((a -> ConfigFile -> m a) -> a -> [ConfigFile] -> m a)
-> (a -> ConfigFile -> m a) -> a -> [ConfigFile] -> m a
forall a b. (a -> b) -> a -> b
$ \a
val ConfigFile
file →
    ConfigFilesConfig -> ConfigFile -> m (a -> a)
forall (m :: * -> *) a.
(ConfigFileParser m, FromJSON (a -> a)) =>
ConfigFilesConfig -> ConfigFile -> m (a -> a)
readConfigFile ConfigFilesConfig
conf ConfigFile
file m (a -> a) -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val

readConfigFile
    ∷ (ConfigFileParser m, FromJSON (a → a))
    ⇒ ConfigFilesConfig
    → ConfigFile
        -- ^ file path
    → m (a → a)
readConfigFile :: ConfigFilesConfig -> ConfigFile -> m (a -> a)
readConfigFile ConfigFilesConfig
_conf ConfigFile
file =
#ifdef REMOTE_CONFIGS
    if isRemote file then loadRemote _conf file else loadLocal file
#else
    ConfigFile -> m (a -> a)
forall (m :: * -> *) a.
(Functor m, MonadIO m, MonadError Text m, FromJSON (a -> a)) =>
ConfigFile -> m (a -> a)
loadLocal ConfigFile
file
#endif

fileType ∷ T.Text → ConfigFileFormat
fileType :: Text -> ConfigFileFormat
fileType Text
f
    | Text
".yaml" Text -> Text -> Bool
`T.isSuffixOf` Text -> Text
T.toLower Text
f = ConfigFileFormat
Yaml
    | Text
".yml" Text -> Text -> Bool
`T.isSuffixOf` Text -> Text
T.toLower Text
f = ConfigFileFormat
Yaml
    | Text
".json" Text -> Text -> Bool
`T.isSuffixOf` Text -> Text
T.toLower Text
f = ConfigFileFormat
Json
    | Text
".js" Text -> Text -> Bool
`T.isSuffixOf` Text -> Text
T.toLower Text
f = ConfigFileFormat
Json
    | Bool
otherwise = ConfigFileFormat
Other

loadLocal
    ∷ (Functor m, MonadIO m, MonadError T.Text m, FromJSON (a → a))
    ⇒ ConfigFile
        -- ^ file path
    → m (a → a)
loadLocal :: ConfigFile -> m (a -> a)
loadLocal ConfigFile
path = do
    Text -> FilePath -> m ()
forall (m :: * -> *). MonadError Text m => Text -> FilePath -> m ()
validateFilePath Text
"config-file" (Text -> FilePath
T.unpack Text
file)
    Bool
exists ← (Bool
True Bool -> m () -> m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> FilePath -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Text -> FilePath -> m ()
validateFile Text
"config-file" (Text -> FilePath
T.unpack Text
file)) m Bool -> (Text -> m Bool) -> m Bool
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \Text
e → case ConfigFile
path of
        ConfigFileOptional Text
_ → Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        ConfigFileRequired Text
_ → Text -> m Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ Text
"failed to read config file: " Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
e
    if Bool
exists
      then
        IO (Either Text (a -> a)) -> m (Either Text (a -> a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ConfigFileFormat -> Text -> IO (Either Text (a -> a))
forall c.
FromJSON c =>
ConfigFileFormat -> Text -> IO (Either Text c)
parser (Text -> ConfigFileFormat
fileType Text
file) Text
file) m (Either Text (a -> a))
-> (Either Text (a -> a) -> m (a -> a)) -> m (a -> a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left Text
e → Text -> m (a -> a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m (a -> a)) -> Text -> m (a -> a)
forall a b. (a -> b) -> a -> b
$ Text
"failed to parse configuration file " Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
file Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
": " Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text -> Text
forall a s. (Show a, IsString s) => a -> s
sshow Text
e
            Right a -> a
r → (a -> a) -> m (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
r
      else
        (a -> a) -> m (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
forall a. a -> a
id
  where
    file :: Text
file = ConfigFile -> Text
getConfigFile ConfigFile
path

    parser :: ConfigFileFormat -> Text -> IO (Either Text c)
parser ConfigFileFormat
Json Text
f = (FilePath -> Text) -> Either FilePath c -> Either Text c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FilePath -> Text
T.pack (Either FilePath c -> Either Text c)
-> (ByteString -> Either FilePath c) -> ByteString -> Either Text c
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ ByteString -> Either FilePath c
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecodeStrict' (ByteString -> Either Text c)
-> IO ByteString -> IO (Either Text c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
B8.readFile (Text -> FilePath
T.unpack Text
f)
    parser ConfigFileFormat
_ Text
f = (ParseException -> Text)
-> Either ParseException c -> Either Text c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> Text
forall a s. (Show a, IsString s) => a -> s
sshow (Either ParseException c -> Either Text c)
-> IO (Either ParseException c) -> IO (Either Text c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Either ParseException c)
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
Yaml.decodeFileEither (Text -> FilePath
T.unpack Text
f)

data ConfigFileFormat
    = Yaml
    | Json
    | Other
    deriving (Int -> ConfigFileFormat -> ShowS
[ConfigFileFormat] -> ShowS
ConfigFileFormat -> FilePath
(Int -> ConfigFileFormat -> ShowS)
-> (ConfigFileFormat -> FilePath)
-> ([ConfigFileFormat] -> ShowS)
-> Show ConfigFileFormat
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ConfigFileFormat] -> ShowS
$cshowList :: [ConfigFileFormat] -> ShowS
show :: ConfigFileFormat -> FilePath
$cshow :: ConfigFileFormat -> FilePath
showsPrec :: Int -> ConfigFileFormat -> ShowS
$cshowsPrec :: Int -> ConfigFileFormat -> ShowS
Show, ReadPrec [ConfigFileFormat]
ReadPrec ConfigFileFormat
Int -> ReadS ConfigFileFormat
ReadS [ConfigFileFormat]
(Int -> ReadS ConfigFileFormat)
-> ReadS [ConfigFileFormat]
-> ReadPrec ConfigFileFormat
-> ReadPrec [ConfigFileFormat]
-> Read ConfigFileFormat
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ConfigFileFormat]
$creadListPrec :: ReadPrec [ConfigFileFormat]
readPrec :: ReadPrec ConfigFileFormat
$creadPrec :: ReadPrec ConfigFileFormat
readList :: ReadS [ConfigFileFormat]
$creadList :: ReadS [ConfigFileFormat]
readsPrec :: Int -> ReadS ConfigFileFormat
$creadsPrec :: Int -> ReadS ConfigFileFormat
Read, ConfigFileFormat -> ConfigFileFormat -> Bool
(ConfigFileFormat -> ConfigFileFormat -> Bool)
-> (ConfigFileFormat -> ConfigFileFormat -> Bool)
-> Eq ConfigFileFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigFileFormat -> ConfigFileFormat -> Bool
$c/= :: ConfigFileFormat -> ConfigFileFormat -> Bool
== :: ConfigFileFormat -> ConfigFileFormat -> Bool
$c== :: ConfigFileFormat -> ConfigFileFormat -> Bool
Eq, Eq ConfigFileFormat
Eq ConfigFileFormat
-> (ConfigFileFormat -> ConfigFileFormat -> Ordering)
-> (ConfigFileFormat -> ConfigFileFormat -> Bool)
-> (ConfigFileFormat -> ConfigFileFormat -> Bool)
-> (ConfigFileFormat -> ConfigFileFormat -> Bool)
-> (ConfigFileFormat -> ConfigFileFormat -> Bool)
-> (ConfigFileFormat -> ConfigFileFormat -> ConfigFileFormat)
-> (ConfigFileFormat -> ConfigFileFormat -> ConfigFileFormat)
-> Ord ConfigFileFormat
ConfigFileFormat -> ConfigFileFormat -> Bool
ConfigFileFormat -> ConfigFileFormat -> Ordering
ConfigFileFormat -> ConfigFileFormat -> ConfigFileFormat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ConfigFileFormat -> ConfigFileFormat -> ConfigFileFormat
$cmin :: ConfigFileFormat -> ConfigFileFormat -> ConfigFileFormat
max :: ConfigFileFormat -> ConfigFileFormat -> ConfigFileFormat
$cmax :: ConfigFileFormat -> ConfigFileFormat -> ConfigFileFormat
>= :: ConfigFileFormat -> ConfigFileFormat -> Bool
$c>= :: ConfigFileFormat -> ConfigFileFormat -> Bool
> :: ConfigFileFormat -> ConfigFileFormat -> Bool
$c> :: ConfigFileFormat -> ConfigFileFormat -> Bool
<= :: ConfigFileFormat -> ConfigFileFormat -> Bool
$c<= :: ConfigFileFormat -> ConfigFileFormat -> Bool
< :: ConfigFileFormat -> ConfigFileFormat -> Bool
$c< :: ConfigFileFormat -> ConfigFileFormat -> Bool
compare :: ConfigFileFormat -> ConfigFileFormat -> Ordering
$ccompare :: ConfigFileFormat -> ConfigFileFormat -> Ordering
$cp1Ord :: Eq ConfigFileFormat
Ord, Int -> ConfigFileFormat
ConfigFileFormat -> Int
ConfigFileFormat -> [ConfigFileFormat]
ConfigFileFormat -> ConfigFileFormat
ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
ConfigFileFormat
-> ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
(ConfigFileFormat -> ConfigFileFormat)
-> (ConfigFileFormat -> ConfigFileFormat)
-> (Int -> ConfigFileFormat)
-> (ConfigFileFormat -> Int)
-> (ConfigFileFormat -> [ConfigFileFormat])
-> (ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat])
-> (ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat])
-> (ConfigFileFormat
    -> ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat])
-> Enum ConfigFileFormat
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ConfigFileFormat
-> ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
$cenumFromThenTo :: ConfigFileFormat
-> ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
enumFromTo :: ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
$cenumFromTo :: ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
enumFromThen :: ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
$cenumFromThen :: ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
enumFrom :: ConfigFileFormat -> [ConfigFileFormat]
$cenumFrom :: ConfigFileFormat -> [ConfigFileFormat]
fromEnum :: ConfigFileFormat -> Int
$cfromEnum :: ConfigFileFormat -> Int
toEnum :: Int -> ConfigFileFormat
$ctoEnum :: Int -> ConfigFileFormat
pred :: ConfigFileFormat -> ConfigFileFormat
$cpred :: ConfigFileFormat -> ConfigFileFormat
succ :: ConfigFileFormat -> ConfigFileFormat
$csucc :: ConfigFileFormat -> ConfigFileFormat
Enum, ConfigFileFormat
ConfigFileFormat -> ConfigFileFormat -> Bounded ConfigFileFormat
forall a. a -> a -> Bounded a
maxBound :: ConfigFileFormat
$cmaxBound :: ConfigFileFormat
minBound :: ConfigFileFormat
$cminBound :: ConfigFileFormat
Bounded, Typeable, (forall x. ConfigFileFormat -> Rep ConfigFileFormat x)
-> (forall x. Rep ConfigFileFormat x -> ConfigFileFormat)
-> Generic ConfigFileFormat
forall x. Rep ConfigFileFormat x -> ConfigFileFormat
forall x. ConfigFileFormat -> Rep ConfigFileFormat x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConfigFileFormat x -> ConfigFileFormat
$cfrom :: forall x. ConfigFileFormat -> Rep ConfigFileFormat x
Generic)

instance NFData ConfigFileFormat

#ifdef REMOTE_CONFIGS
isRemote
    ∷ ConfigFile
    → Bool
isRemote path = L.any (`T.isPrefixOf` getConfigFile path) ["http://", "https://"]

yamlMimeType ∷ IsString s ⇒ [s]
yamlMimeType = map fromString ["application/x-yaml", "text/yaml"]

-- | Defined in  RFC 4627
--
jsonMimeType ∷ IsString s ⇒ [s]
jsonMimeType = map fromString ["application/json"]

contentType
    ∷ B8.ByteString
        -- ^ value of an HTTP @Content-Type@ header
    → ConfigFileFormat
contentType headerValue
    | CI.foldCase "yaml" `B8.isInfixOf` CI.foldCase headerValue = Yaml
    | CI.foldCase "json" `B8.isInfixOf` CI.foldCase headerValue = Json
    | otherwise = Other

loadRemote
    ∷ (ConfigFileParser m, FromJSON (a → a))
    ⇒ ConfigFilesConfig
    → ConfigFile
        -- ^ URL
    → m (a → a)
loadRemote conf path = do
    validateHttpOrHttpsUrl "config-file" (T.unpack url)
    result ← (Just <$> doHttp) `catchAnyDeep` \e →
        case path of
            ConfigFileOptional _ → do
                liftIO ∘ T.hPutStrLn stderr $ "WARNING: failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e
                return Nothing
            ConfigFileRequired _ → throwError $ "failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e

    case result of
        Nothing → return id
        Just (format, d) → case (parser format) d of
            Left e → throwError $ "failed to parse remote configuration " ⊕ url ⊕ ": " ⊕ e
            Right r → return r
  where
    parser Json = first T.pack ∘ eitherDecodeStrict'
    parser _ = first sshow ∘ Yaml.decodeEither'

    url = getConfigFile path
    policy = _cfcHttpsPolicy conf
    doHttp = liftIO $ do
        request ← (HTTP.parseUrlThrow $ T.unpack url)
            <&> over requestHeaders ((:) acceptHeader)
        resp ← httpWithValidationPolicy request policy
        let format = maybe Other contentType ∘ L.lookup HTTP.hContentType $ HTTP.responseHeaders resp
        return (format, LB.toStrict (HTTP.responseBody resp))

    acceptHeader = (HTTP.hAccept, B8.intercalate "," (yamlMimeType ⊕ jsonMimeType))

requestHeaders ∷ Lens' HTTP.Request HTTP.RequestHeaders
requestHeaders = lens HTTP.requestHeaders $ \s a → s { HTTP.requestHeaders = a }

#endif