{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

-- |
-- Module: Configuration.Utils.ConfigFile
-- Description: Parsing of Configuration Files with Default Values
-- Copyright: Copyright © 2015 PivotCloud, Inc.
-- License: MIT
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--
-- This module provides tools for defining configuration file
-- parsers via instances of 'FromJSON'.
--
-- Unlike /normal/ 'FromJSON' instances the parsers for configuration
-- files are expected to yield an update function that takes
-- a value and updates the value with the settings from the configuration
-- file.
--
-- Assuming that
--
-- * all configuration types are nested Haskell records or
--   simple types and
--
-- * that there are lenses for all record fields
--
-- usually the operators '..:' and '%.:' are all that is needed from this module.
--
-- The module "Configuration.Utils.Monoid" provides tools for the case that
-- a /simple type/ is a container with a monoid instance, such as @List@ or
-- @HashMap@.
--
-- The module "Configuration.Utils.Maybe" explains the usage of optional
-- 'Maybe' values in configuration types.
--
module Configuration.Utils.ConfigFile
(
-- * Parsing of Configuration Files with Default Values
  setProperty
, (..:)
, (!..:)
, updateProperty
, (%.:)

-- * Configuration File Parsing Policy
, ConfigFile(..)
, ConfigFilesConfig(..)
#if REMOTE_CONFIGS
, cfcHttpsPolicy
#endif
, defaultConfigFilesConfig
, pConfigFilesConfig

-- * Miscellaneous Utilities
, dropAndUncaml
, module Data.Aeson
) where

import Configuration.Utils.CommandLine
import Configuration.Utils.Internal

import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Char
import Data.Foldable
import qualified Data.HashMap.Strict as H
import Data.Maybe
import Data.Monoid.Unicode
import Data.String
import qualified Data.Text as T
import Data.Typeable

import Prelude hiding (any, concatMap, mapM_)

#ifdef REMOTE_CONFIGS
import Configuration.Utils.Internal.HttpsCertPolicy
import Configuration.Utils.Operators
#endif

-- | A JSON 'Value' parser for a property of a given
-- 'Object' that updates a setter with the parsed value.
--
-- > data Auth = Auth
-- >     { _userId ∷ !Int
-- >     , _pwd ∷ !String
-- >     }
-- >
-- > userId ∷ Functor f ⇒ (Int → f Int) → Auth → f Auth
-- > userId f s = (\u → s { _userId = u }) <$> f (_userId s)
-- >
-- > pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth
-- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)
-- >
-- > -- or with lenses and TemplateHaskell just:
-- > -- $(makeLenses ''Auth)
-- >
-- > instance FromJSON (Auth → Auth) where
-- >     parseJSON = withObject "Auth" $ \o → id
-- >         <$< setProperty user "user" p o
-- >         <*< setProperty pwd "pwd" parseJSON o
-- >       where
-- >         p = withText "user" $ \case
-- >             "alice" → pure (0 ∷ Int)
-- >             "bob" → pure 1
-- >             e → fail $ "unrecognized user " ⊕ e
--
setProperty
    ∷ Lens' a b -- ^ a lens into the target that is updated by the parser
    → T.Text -- ^ the JSON property name
    → (Value → Parser b) -- ^ the JSON 'Value' parser that is used to parse the value of the property
    → Object -- ^ the parsed JSON 'Value' 'Object'
    → Parser (a → a)
setProperty :: Lens' a b
-> Text -> (Value -> Parser b) -> Object -> Parser (a -> a)
setProperty Lens' a b
s Text
k Value -> Parser b
p Object
o = case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
k Object
o of
    Maybe Value
Nothing → (a -> a) -> Parser (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id
    Just Value
v → ((b -> Identity b) -> a -> Identity a) -> b -> a -> a
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> b -> s -> t
set (b -> Identity b) -> a -> Identity a
Lens' a b
s (b -> a -> a) -> Parser b -> Parser (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser b
p Value
v

-- | A variant of the 'setProperty' that uses the default 'parseJSON' method from the
-- 'FromJSON' instance to parse the value of the property. Its usage pattern mimics the
-- usage pattern of the '.:' operator from the aeson library.
--
-- > data Auth = Auth
-- >     { _user ∷ !String
-- >     , _pwd ∷ !String
-- >     }
-- >
-- > user ∷ Functor f ⇒ (String → f String) → Auth → f Auth
-- > user f s = (\u → s { _user = u }) <$> f (_user s)
-- >
-- > pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth
-- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)
-- >
-- > -- or with lenses and TemplateHaskell just:
-- > -- $(makeLenses ''Auth)
-- >
-- > instance FromJSON (Auth → Auth) where
-- >     parseJSON = withObject "Auth" $ \o → id
-- >         <$< user ..: "user" % o
-- >         <*< pwd ..: "pwd" % o
--
(..:) ∷ FromJSON b ⇒ Lens' a b → T.Text → Object → Parser (a → a)
..: :: Lens' a b -> Text -> Object -> Parser (a -> a)
(..:) Lens' a b
s Text
k = Lens' a b
-> Text -> (Value -> Parser b) -> Object -> Parser (a -> a)
forall a b.
Lens' a b
-> Text -> (Value -> Parser b) -> Object -> Parser (a -> a)
setProperty Lens' a b
s Text
k Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON
infix 6 ..:
{-# INLINE (..:) #-}

-- | A JSON parser for a function that modifies a property
-- of a given 'Object' and updates a setter with the parsed
-- function.
--
-- This function is useful when a 'FromJSON' instance isn't available.
-- When a 'FromJSON' instance exists, the '%.:' provides a more
-- ideomatic alternative.
--
-- > data HttpURL = HttpURL
-- >     { _auth ∷ !Auth
-- >     , _domain ∷ !String
-- >     }
-- >
-- > auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL
-- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)
-- >
-- > domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)
-- >
-- > path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > path f s = (\u → s { _path = u }) <$> f (_path s)
-- >
-- > -- or with lenses and TemplateHaskell just:
-- > -- $(makeLenses ''HttpURL)
-- >
-- > instance FromJSON (HttpURL → HttpURL) where
-- >     parseJSON = withObject "HttpURL" $ \o → id
-- >         <$< updateProperty auth "auth" parseJSON o
-- >         <*< setProperty domain "domain" parseJSON o
--
updateProperty
    ∷ Lens' a b
    → T.Text
    → (Value → Parser (b → b))
    → Object
    → Parser (a → a)
updateProperty :: Lens' a b
-> Text -> (Value -> Parser (b -> b)) -> Object -> Parser (a -> a)
updateProperty Lens' a b
s Text
k Value -> Parser (b -> b)
p Object
o = case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
k Object
o of
    Maybe Value
Nothing → (a -> a) -> Parser (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id
    Just Value
v → ((b -> Identity b) -> a -> Identity a) -> (b -> b) -> a -> a
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over (b -> Identity b) -> a -> Identity a
Lens' a b
s ((b -> b) -> a -> a) -> Parser (b -> b) -> Parser (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (b -> b)
p Value
v
{-# INLINE updateProperty #-}

-- | A variant of 'updateProperty' that uses the 'FromJSON' instance
-- for the update function. It mimics the aeson operator '.:'.
-- It creates a parser that modifies a setter with a parsed function.
--
-- > data HttpURL = HttpURL
-- >     { _auth ∷ !Auth
-- >     , _domain ∷ !String
-- >     }
-- >
-- > auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL
-- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)
-- >
-- > domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)
-- >
-- > path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL
-- > path f s = (\u → s { _path = u }) <$> f (_path s)
-- >
-- > -- or with lenses and TemplateHaskell just:
-- > -- $(makeLenses ''HttpURL)
-- >
-- > instance FromJSON (HttpURL → HttpURL) where
-- >     parseJSON = withObject "HttpURL" $ \o → id
-- >         <$< auth %.: "auth" % o
-- >         <*< domain ..: "domain" % o
--
(%.:) ∷ FromJSON (b → b) ⇒ Lens' a b → T.Text → Object → Parser (a → a)
%.: :: Lens' a b -> Text -> Object -> Parser (a -> a)
(%.:) Lens' a b
s Text
k = Lens' a b
-> Text -> (Value -> Parser (b -> b)) -> Object -> Parser (a -> a)
forall a b.
Lens' a b
-> Text -> (Value -> Parser (b -> b)) -> Object -> Parser (a -> a)
updateProperty Lens' a b
s Text
k Value -> Parser (b -> b)
forall a. FromJSON a => Value -> Parser a
parseJSON
infix 6 %.:
{-# INLINE (%.:) #-}

-- | This operator requires that a value is explicitly provided in a
-- configuration file, thus preventing the default value from being used.
-- Otherwise this operator does the same as '(..:)'.
--
(!..:)
    ∷ FromJSON b
    ⇒ Lens' a b
    → T.Text
    → Object
    → Parser (a → a)
!..: :: Lens' a b -> Text -> Object -> Parser (a -> a)
(!..:) Lens' a b
l Text
property Object
o = ((b -> Identity b) -> a -> Identity a) -> b -> a -> a
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> b -> s -> t
set (b -> Identity b) -> a -> Identity a
Lens' a b
l (b -> a -> a) -> Parser b -> Parser (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Text -> Parser b
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
property)
{-# INLINE (!..:) #-}

-- -------------------------------------------------------------------------- --
-- Config File Parsing Policy

data ConfigFile
    = ConfigFileRequired { ConfigFile -> Text
getConfigFile ∷ !T.Text }
    | ConfigFileOptional { getConfigFile ∷ !T.Text }
    deriving (Int -> ConfigFile -> ShowS
[ConfigFile] -> ShowS
ConfigFile -> String
(Int -> ConfigFile -> ShowS)
-> (ConfigFile -> String)
-> ([ConfigFile] -> ShowS)
-> Show ConfigFile
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigFile] -> ShowS
$cshowList :: [ConfigFile] -> ShowS
show :: ConfigFile -> String
$cshow :: ConfigFile -> String
showsPrec :: Int -> ConfigFile -> ShowS
$cshowsPrec :: Int -> ConfigFile -> ShowS
Show, ReadPrec [ConfigFile]
ReadPrec ConfigFile
Int -> ReadS ConfigFile
ReadS [ConfigFile]
(Int -> ReadS ConfigFile)
-> ReadS [ConfigFile]
-> ReadPrec ConfigFile
-> ReadPrec [ConfigFile]
-> Read ConfigFile
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ConfigFile]
$creadListPrec :: ReadPrec [ConfigFile]
readPrec :: ReadPrec ConfigFile
$creadPrec :: ReadPrec ConfigFile
readList :: ReadS [ConfigFile]
$creadList :: ReadS [ConfigFile]
readsPrec :: Int -> ReadS ConfigFile
$creadsPrec :: Int -> ReadS ConfigFile
Read, ConfigFile -> ConfigFile -> Bool
(ConfigFile -> ConfigFile -> Bool)
-> (ConfigFile -> ConfigFile -> Bool) -> Eq ConfigFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigFile -> ConfigFile -> Bool
$c/= :: ConfigFile -> ConfigFile -> Bool
== :: ConfigFile -> ConfigFile -> Bool
$c== :: ConfigFile -> ConfigFile -> Bool
Eq, Eq ConfigFile
Eq ConfigFile
-> (ConfigFile -> ConfigFile -> Ordering)
-> (ConfigFile -> ConfigFile -> Bool)
-> (ConfigFile -> ConfigFile -> Bool)
-> (ConfigFile -> ConfigFile -> Bool)
-> (ConfigFile -> ConfigFile -> Bool)
-> (ConfigFile -> ConfigFile -> ConfigFile)
-> (ConfigFile -> ConfigFile -> ConfigFile)
-> Ord ConfigFile
ConfigFile -> ConfigFile -> Bool
ConfigFile -> ConfigFile -> Ordering
ConfigFile -> ConfigFile -> ConfigFile
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 :: ConfigFile -> ConfigFile -> ConfigFile
$cmin :: ConfigFile -> ConfigFile -> ConfigFile
max :: ConfigFile -> ConfigFile -> ConfigFile
$cmax :: ConfigFile -> ConfigFile -> ConfigFile
>= :: ConfigFile -> ConfigFile -> Bool
$c>= :: ConfigFile -> ConfigFile -> Bool
> :: ConfigFile -> ConfigFile -> Bool
$c> :: ConfigFile -> ConfigFile -> Bool
<= :: ConfigFile -> ConfigFile -> Bool
$c<= :: ConfigFile -> ConfigFile -> Bool
< :: ConfigFile -> ConfigFile -> Bool
$c< :: ConfigFile -> ConfigFile -> Bool
compare :: ConfigFile -> ConfigFile -> Ordering
$ccompare :: ConfigFile -> ConfigFile -> Ordering
$cp1Ord :: Eq ConfigFile
Ord, Typeable)

-- | An /internal/ type for the meta configuration that specifies how the
-- configuration files are loaded and parsed.
--
#if REMOTE_CONFIGS
data ConfigFilesConfig = ConfigFilesConfig
    { _cfcHttpsPolicy ∷ !HttpsCertPolicy
    }
    deriving (Show, Eq, Typeable)

cfcHttpsPolicy ∷ Lens' ConfigFilesConfig HttpsCertPolicy
cfcHttpsPolicy = lens _cfcHttpsPolicy $ \a b → a { _cfcHttpsPolicy = b }

defaultConfigFilesConfig ∷ ConfigFilesConfig
defaultConfigFilesConfig = ConfigFilesConfig
    { _cfcHttpsPolicy = defaultHttpsCertPolicy
    }

pConfigFilesConfig ∷ MParser ConfigFilesConfig
pConfigFilesConfig = id
    <$< cfcHttpsPolicy %:: pHttpsCertPolicy "config-"

#else

data ConfigFilesConfig = ConfigFilesConfig {}

defaultConfigFilesConfig ∷ ConfigFilesConfig
defaultConfigFilesConfig :: ConfigFilesConfig
defaultConfigFilesConfig = ConfigFilesConfig :: ConfigFilesConfig
ConfigFilesConfig {}

pConfigFilesConfig ∷ MParser ConfigFilesConfig
pConfigFilesConfig :: MParser ConfigFilesConfig
pConfigFilesConfig = (ConfigFilesConfig -> ConfigFilesConfig)
-> MParser ConfigFilesConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigFilesConfig -> ConfigFilesConfig
forall a. a -> a
id
#endif

-- -------------------------------------------------------------------------- --
-- Miscellaneous Utilities

dropAndUncaml ∷ Int → String → String
dropAndUncaml :: Int -> ShowS
dropAndUncaml Int
_ String
"" = String
""
dropAndUncaml Int
i String
l = case Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
i String
l of
    [] -> String
l
    (Char
h:String
t) -> Char -> Char
toLower Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Char
x → if Char -> Bool
isUpper Char
x then String
"-" String -> ShowS
forall α. Monoid α => α -> α -> α
⊕ [Char -> Char
toLower Char
x] else [Char
x]) String
t