{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
module Configuration.Utils.Internal.ConfigFileReader
(
parseConfigFiles
, readConfigFile
, ConfigFileFormat(..)
, loadLocal
#ifdef REMOTE_CONFIGS
, 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
#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
→ [ConfigFile]
→ m a
parseConfigFiles :: forall (m :: * -> *) a.
(ConfigFileParser m, FromJSON (a -> a)) =>
ConfigFilesConfig -> a -> [ConfigFile] -> m a
parseConfigFiles ConfigFilesConfig
conf = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall a b. (a -> b) -> a -> b
$ \a
val ConfigFile
file →
forall (m :: * -> *) a.
(ConfigFileParser m, FromJSON (a -> a)) =>
ConfigFilesConfig -> ConfigFile -> m (a -> a)
readConfigFile ConfigFilesConfig
conf ConfigFile
file forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val
readConfigFile
∷ (ConfigFileParser m, FromJSON (a → a))
⇒ ConfigFilesConfig
→ ConfigFile
→ m (a → a)
readConfigFile :: forall (m :: * -> *) a.
(ConfigFileParser m, FromJSON (a -> a)) =>
ConfigFilesConfig -> ConfigFile -> m (a -> a)
readConfigFile ConfigFilesConfig
_conf ConfigFile
file =
#ifdef REMOTE_CONFIGS
if isRemote file then loadRemote _conf file else loadLocal file
#else
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
→ m (a → a)
loadLocal :: forall (m :: * -> *) a.
(Functor m, MonadIO m, MonadError Text m, FromJSON (a -> a)) =>
ConfigFile -> m (a -> a)
loadLocal ConfigFile
path = do
forall (m :: * -> *). MonadError Text m => Text -> FilePath -> m ()
validateFilePath Text
"config-file" (Text -> FilePath
T.unpack Text
file)
Bool
exists ← (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Text -> FilePath -> m ()
validateFile Text
"config-file" (Text -> FilePath
T.unpack Text
file)) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \Text
e → case ConfigFile
path of
ConfigFileOptional Text
_ → forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ConfigFileRequired Text
_ → forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"failed to read config file: " forall α. Monoid α => α -> α -> α
⊕ Text
e
if Bool
exists
then
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall {c}.
FromJSON c =>
ConfigFileFormat -> Text -> IO (Either Text c)
parser (Text -> ConfigFileFormat
fileType Text
file) Text
file) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Text
e → forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"failed to parse configuration file " forall α. Monoid α => α -> α -> α
⊕ Text
file forall α. Monoid α => α -> α -> α
⊕ Text
": " forall α. Monoid α => α -> α -> α
⊕ forall a s. (Show a, IsString s) => a -> s
sshow Text
e
Right a -> a
r → forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
r
else
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FilePath -> Text
T.pack forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecodeStrict' 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 = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a s. (Show a, IsString s) => a -> s
sshow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
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]
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
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
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
Ord, Int -> ConfigFileFormat
ConfigFileFormat -> Int
ConfigFileFormat -> [ConfigFileFormat]
ConfigFileFormat -> ConfigFileFormat
ConfigFileFormat -> ConfigFileFormat -> [ConfigFileFormat]
ConfigFileFormat
-> ConfigFileFormat -> ConfigFileFormat -> [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
forall a. a -> a -> Bounded a
maxBound :: ConfigFileFormat
$cmaxBound :: ConfigFileFormat
minBound :: ConfigFileFormat
$cminBound :: ConfigFileFormat
Bounded, Typeable, 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"]
jsonMimeType ∷ IsString s ⇒ [s]
jsonMimeType = map fromString ["application/json"]
contentType
∷ B8.ByteString
→ 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
→ 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