diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,45 +1,134 @@
-# Conferer
-
-## what, why and a bit of how
+Conferer
+
+
+ 
+
+
+ 
+
+
+ 
+
+
-VERY UNSTABLE DON'T USE IN PRODUCTION JUST YET
+## The problem
-Conferer is a library that defines ways to get configuration for your Haskell
-application and the libraries it uses, which is at heart string keys which map
-to other strings.
+Have you ever tried configuring a Haskell application? If you are not the author
+you are usually out of luck and the only way to configure it is recompiling, and
+even if you are the author you have to write that logic yourself (reading env vars,
+files or cli params), what about partial updates? and environments? or error handling?
-To get this map we use `Providers` which define a way to get a key (eg.
-`db.username`) that may or may not exist, we then use a list of providers for
-getting the value for that key (position on the list defines priority). This
-allows adding new providers easily (for example a dhall file provider,
-a git repo or a etcd database)
+## One solution: Conferer
-The other side of this is that we have the `FromConfig` which gets some value
-from a `Config` at a certain key possibly using only keys under some namespacing
-key
+Conferer is a library that defines ways of getting configuration for your
+Haskell application and the libraries it uses in a very ergonomical way.
-## Example (not implemented)
+## Example: one Settings
-Let's say I want to configure warp. Let's say we wrote this program.
+Let's say I want to configure a warp server, then we'd do:
```haskell
main = do
- -- by default gets cli parameters, envvars and json file
- config <- getDefaultConfigFor "awesomeapp"
- warpConfig :: Warp.Settings <- getKey "warp" config
+ -- First we create a Config, which defines which sources our config will be
+ -- reading, by default cli params, env vars and .properties files
+ config <- defaultConfig "awesomeapp"
+ -- Then we use getFromConfig with some arbitrary key (to scope the server
+ -- config) and we use our Config to generate a Warp Settings
+ warpConfig :: Warp.Settings <- getFromConfig "server" config
+ -- Afterwards we use the Settings as usual
Warp.runSettings warpConfig myApp
```
Now I need to chage the port of the app, I can change it by either:
-* Setting cli params like `./myApp -Cwarp.port=5555`
-* Setting an environment variable called `AWESOMEAPP_WARP_PORT=5555`
-* In a json file you can have `{"warp": {"port": 5555}}`
+* Setting cli params like `./myApp --server.port=5555`
+* Setting an environment variable called `AWESOMEAPP_SERVER_PORT=5555`
+* In a `config/dev.properties` file, you can have `server.port=5555`
And you may also get that value from different configuration providers like
-redis or etc or whichever you may need.
+redis, json file, dhall file or whichever you may need.
+## Example 2: many different values with defaults
+
+Let's say I want to configure a warp server and a redis db (using hedis), To
+do that we'd do:
+
+```haskell
+
+-- First we create our configuration record which holds all the configurations
+-- our app needs
+data AppConfig = AppConfig
+ { appConfigWarp :: Settings
+ -- ^- From Warp
+ , appConfigHedis :: ConnectionInfo
+ -- ^- From Hedis
+ , appConfigSecret :: Text
+ -- ^- Some custom value we need
+ } deriving (Generic)
+ -- ^- We need to derive Generic to derive FromConfig
+
+-- This typeclass defines how to create our type from a bunch of string based
+-- key/values, (which our Config is), for records we can derive it using
+-- Generics
+instance FromConfig AppConfig
+
+-- Now we need a default value for our app, all apps should be able to work
+-- at least somewhat stupidly even if the user doens't supply configurations
+-- at all
+instance DefaultConfig AppConfig where
+ configDef = AppConfig
+ { appConfigWarp = setPort 2222 configDef
+ -- ^- We want the default Warp config but the port should be 2222
+ -- if the config doesn't mention it
+ , appConfigHedis = configDef
+ -- ^- defaults for hedis are ok
+ , appConfigSecret = "very secret... shhh"
+ -- ^- we decide some random default, notice that Text has no default
+ -- so using configDef here won't compile
+ }
+
+
+main = do
+ -- Like last time we create the config
+ config <- defaultConfig "awesomeapp"
+ -- Then we use getFromRootConfig without a key since Generics on AppConfig
+ -- already scoped everything inside itself and we use our Config to
+ -- generate an AppConfig
+ warpConfig :: AppConfig <- getFromRootConfig config
+
+ -- Afterwards we use the Settings as usual
+ Warp.runSettings warpConfig myApp
+```
+
+Now to configure our app we can use the same sources as before (env vars, cli,
+files, etc) but using the following flags we can configure:
+
+* `--warp.port=5555`: set warp's server port to 5555
+* `--secret=real_secrets`: set our custom secret to `"real_secrets"`
+* `--hedis=redis://username:password@host:42/2`: set hedis' connection to that
+* `--hedis.host=redis.example.com`: set hedis' connection host to `redis.example.com`
+
+
+## Existing providers
+
+Providers usually incur in many dependencies so they are split into different
+packages
+
+* *[Json](https://hackage.haskell.org/package/conferer-provider-json)* (depends on `aeson`)
+* *[Dhall](https://hackage.haskell.org/package/conferer-provider-dhall)* (depends on `dhall`)
+* *[Yaml](https://hackage.haskell.org/package/conferer-provider-yaml)* (depends on `yaml`)
+
+## Existing FromConfig instances
+
+Default instances for fetching a values from a config (usually a config value
+for some library)
+
+* *[snap-server](https://hackage.haskell.org/package/conferer-snap)*
+* *[warp](https://hackage.haskell.org/package/conferer-warp)*
+* *[hedis](https://hackage.haskell.org/package/conferer-hedis)*
+* *[hspec](https://hackage.haskell.org/package/conferer-hspec)*
+
## Utilities
There are as well some utilities to change providers:
@@ -53,7 +142,6 @@
## Future maybe things
* Interpolate keys with other keys: `{a: "db", b: "${a}_thing"}`, getting `b`
- will give `"db_thing"` (maybe)
+ will give `"db_thing"` (maybe) even in different levels of configuration
* A LOT of providers
* A LOT of `FromConfig` implementations
-* Docs
diff --git a/conferer.cabal b/conferer.cabal
--- a/conferer.cabal
+++ b/conferer.cabal
@@ -4,10 +4,10 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: 1f741ccac642f7efeeebac945b43d38c5662447adc1d2396aae94def3780aabb
+-- hash: e9e6edef27397421e3ed20cd7b4269e086ded2fc7fd679dac79be16cf923d188
name: conferer
-version: 0.2.0.0
+version: 0.3.0.0
synopsis: Configuration management library
description: Library to abstract the parsing of many haskell config values from different config sources
@@ -27,7 +27,7 @@
exposed-modules:
Conferer
Conferer.Core
- Conferer.FetchFromConfig.Basics
+ Conferer.FromConfig.Basics
Conferer.Provider.CLIArgs
Conferer.Provider.Env
Conferer.Provider.Files
@@ -50,11 +50,11 @@
, text >=1.1 && <1.3
default-language: Haskell2010
-test-suite spec
+test-suite specs
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
- Conferer.FetchFromConfig.BasicsSpec
+ Conferer.FromConfig.BasicsSpec
Conferer.GenericsSpec
Conferer.Provider.ArgsSpec
Conferer.Provider.EnvSpec
diff --git a/src/Conferer.hs b/src/Conferer.hs
--- a/src/Conferer.hs
+++ b/src/Conferer.hs
@@ -18,7 +18,7 @@
--
-- @
-- import Conferer
- -- import Conferer.FetchFromConfig.Warp () -- from package conferer-warp
+ -- import Conferer.FromConfig.Warp () -- from package conferer-warp
--
-- main = do
-- config <- 'defaultConfig' \"awesomeapp\"
@@ -37,7 +37,7 @@
-- json files, properties files, env vars, etc.
-- ** Getting configuration for existing libraries
- -- | There is a typeclass 'FetchFromConfig' that defines how to get a type
+ -- | There is a typeclass 'FromConfig' that defines how to get a type
-- from a config, they are implemented in different packages since the
-- weight of the dependencies would be too high, the package is usually
-- named as @conferer-DEPENDENCY@ where DEPENDENCY is the name of the dependency (
@@ -47,7 +47,7 @@
-- ** Providing key value pairs for configuration
-- | There is one important type in conferer: 'Config' from which, given a key
- -- (eg: @warp@) you can get anything that implements 'FetchFromConfig' (like
+ -- (eg: @warp@) you can get anything that implements 'FromConfig' (like
-- 'Warp.Settings')
--
-- Internally a 'Config' is made of many 'Provider's which have a simpler
@@ -90,8 +90,8 @@
import Data.Text (Text)
import Data.Function ((&))
-import Conferer.Core (emptyConfig, addProvider, getFromConfig, getKey, unsafeGetKey, (/.), withDefaults)
-import Conferer.Types (Config, Key(..), ProviderCreator, Provider(..), FetchFromConfig(..))
+import Conferer.Core (emptyConfig, addProvider, getFromConfig, getFromRootConfig, getFromConfigWithDefault, safeGetFromConfig, safeGetFromConfigWithDefault, getKey, unsafeGetKey, (/.), withDefaults)
+import Conferer.Types (Config, Key(..), ProviderCreator, Provider(..), DefaultConfig(..), FromConfig(..))
import Conferer.Provider.Env
import Conferer.Provider.Simple
import Conferer.Provider.Namespaced
diff --git a/src/Conferer/Core.hs b/src/Conferer/Core.hs
--- a/src/Conferer/Core.hs
+++ b/src/Conferer/Core.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
module Conferer.Core where
import Data.Text (Text)
@@ -6,7 +8,7 @@
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Typeable (Typeable, Proxy(..), typeRep)
-import Control.Exception (throw)
+import Control.Exception (try, throw, throwIO, evaluate)
import Conferer.Provider.Simple
import Conferer.Types
@@ -26,14 +28,57 @@
Nothing -> go providers
--- | Fetch a value from a config key that's parsed using the FetchFromConfig
--- instance.
+-- | Fetch a value from a config under some specific key that's parsed using the 'FromConfig'
+-- instance, and as a default it uses the value from 'DefaultConfig'.
--
--- This function throws an exception if the key is not found.
-getFromConfig :: forall a. (Typeable a, FetchFromConfig a) => Key -> Config -> IO a
+-- Notes:
+-- - This function may throw an exception if parsing fails for any subkey
+getFromConfig :: forall a. (Typeable a, FromConfig a, DefaultConfig a) => Key -> Config -> IO a
getFromConfig key config =
- fromMaybe (throw $ FailedToFetchError key (typeRep (Proxy :: Proxy a)))
- <$> fetch key config
+ getFromConfigWithDefault key config configDef
+
+-- | Same as 'getFromConfig' using the root key
+--
+-- Notes:
+-- - This function may throw an exception if parsing fails for any subkey
+getFromRootConfig :: forall a. (Typeable a, FromConfig a, DefaultConfig a) => Config -> IO a
+getFromRootConfig config =
+ getFromConfig "" config
+
+
+-- | Same as 'getFromConfig' but with a user defined default (instead of 'DefaultConfig' instance)
+--
+-- Useful for fetching primitive types
+getFromConfigWithDefault :: forall a. (Typeable a, FromConfig a) => Key -> Config -> a -> IO a
+getFromConfigWithDefault key config configDefault =
+ safeGetFromConfigWithDefault key config configDefault
+ >>= \case
+ Just value -> do
+ evaluate value
+ Nothing ->
+ throwIO $ FailedToFetchError key (typeRep (Proxy :: Proxy a))
+
+-- | Fetch a value from a config key that's parsed using the FromConfig instance.
+--
+-- Note: This function does not use default so the value must be fully defined by the config only,
+-- meaning using this function for many records will always result in 'Nothing' (if the record contains
+-- a value that can never be retrieved like a function)
+safeGetFromConfig :: forall a. (Typeable a, FromConfig a, DefaultConfig a) => Key -> Config -> IO (Maybe a)
+safeGetFromConfig key config =
+ safeGetFromConfigWithDefault key config configDef
+
+-- | Same as 'safeGetFromConfig' but with a user defined default
+safeGetFromConfigWithDefault :: forall a. (Typeable a, FromConfig a) => Key -> Config -> a -> IO (Maybe a)
+safeGetFromConfigWithDefault key config configDefault = do
+ totalValue <- evaluate =<< fetchFromConfig key config
+ case totalValue of
+ Just value -> do
+ Just <$> evaluate value
+ Nothing -> do
+ result :: Either FailedToFetchError a <- try . (evaluate =<<) . updateFromConfig key config $ configDefault
+ case result of
+ Right a -> Just <$> evaluate a
+ Left e -> return Nothing
-- | Create a new 'Key' by concatenating two existing keys.
(/.) :: Key -> Key -> Key
diff --git a/src/Conferer/FetchFromConfig/Basics.hs b/src/Conferer/FetchFromConfig/Basics.hs
deleted file mode 100644
--- a/src/Conferer/FetchFromConfig/Basics.hs
+++ /dev/null
@@ -1,133 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Conferer.FetchFromConfig.Basics where
-
-import Conferer.Types
-import Conferer.Core (getKey, (/.))
-import Control.Monad (join)
-import Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-import Data.ByteString (ByteString)
-import Data.Maybe (fromMaybe)
-import Control.Exception
-import Data.Char (toLower)
-import Data.Typeable (Typeable, typeRep, Proxy(..))
-import GHC.Generics
-
-import Data.String (IsString, fromString)
-
-import Text.Read (readMaybe)
-
-instance FetchFromConfig Int where
- fetch = fetchFromConfigByRead
-
-instance FetchFromConfig Integer where
- fetch = fetchFromConfigByRead
-
-instance FetchFromConfig Float where
- fetch = fetchFromConfigByRead
-
-instance FetchFromConfig ByteString where
- fetch = fetchFromConfigWith (Just . Text.encodeUtf8)
-
-instance FetchFromConfig a => FetchFromConfig (Maybe a) where
- fetch k config =
- fmap return <$> fetch k config
-
-instance FetchFromConfig String where
- fetch = fetchFromConfigWith (Just . Text.unpack)
-
-instance FetchFromConfig Text where
- fetch = fetchFromConfigWith (Just)
-
-instance FetchFromConfig Bool where
- fetch = fetchFromConfigWith parseBool
- where
- parseBool text =
- case Text.toLower text of
- "false" -> Just False
- "true" -> Just True
- _ -> Nothing
-
-fetchFromConfigByRead :: (Typeable a, Read a) => Key -> Config -> IO (Maybe a)
-fetchFromConfigByRead = fetchFromConfigWith (readMaybe . Text.unpack)
-
-fromValueWith :: (Text -> Maybe a) -> Text -> Maybe a
-fromValueWith parseValue valueAsText = parseValue valueAsText
-
-fetchFromConfigWith :: forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO (Maybe a)
-fetchFromConfigWith parseValue key config = do
- getKey key config >>=
- \case
- Just value ->
- return $
- Just $
- fromMaybe (throw $ ConfigParsingError key value (typeRep (Proxy :: Proxy a))) $
- fromValueWith parseValue value
- Nothing -> return Nothing
-
--- | Concatenate many transformations to the config based on keys and functions
-findKeyAndApplyConfig ::
- forall newvalue config.
- FetchFromConfig newvalue
- => Config -- ^ Complete config
- -> Key -- ^ Key that indicates the part of the config that we care about
- -> Key -- ^ Key that we use to find the config (usually concatenating with the
- -- other key)
- -> (newvalue -> config -> config) -- ^ Function that knows how to use the
- -- value to update the config
- -> config -- ^ Result of the last config updating
- -> IO config -- ^ Updated config
-findKeyAndApplyConfig config k relativeKey f customConfig = do
- t <- fetch @newvalue (k /. relativeKey) config
- case t of
- Nothing -> return customConfig
- Just a -> return $ f a customConfig
-
-instance UpdateFromConfigG inner =>
- UpdateFromConfigG (D1 metadata inner) where
- updateFromConfigG key config (M1 inner) =
- M1 <$> updateFromConfigG key config inner
-
-instance (UpdateFromConfigWithConNameG inner, Constructor constructor) =>
- UpdateFromConfigG (C1 constructor inner) where
- updateFromConfigG key config (M1 inner) =
- M1 <$> updateFromConfigWithConNameG @inner (conName @constructor undefined) key config inner
-
-class UpdateFromConfigWithConNameG f where
- updateFromConfigWithConNameG :: String -> Key -> Config -> f a -> IO (f a)
-
-instance (UpdateFromConfigWithConNameG left, UpdateFromConfigWithConNameG right) =>
- UpdateFromConfigWithConNameG (left :*: right) where
- updateFromConfigWithConNameG s key config (left :*: right) = do
- leftValue <- updateFromConfigWithConNameG @left s key config left
- rightValue <- updateFromConfigWithConNameG @right s key config right
- return (leftValue :*: rightValue)
-
-instance (UpdateFromConfigG inner, Selector selector) =>
- UpdateFromConfigWithConNameG (S1 selector inner) where
- updateFromConfigWithConNameG s key config (M1 inner) =
- let
- applyFirst :: (Char -> Char) -> Text -> Text
- applyFirst f t = case Text.uncons t of
- Just (c, ts) -> Text.cons (f c) ts
- Nothing -> t
-
- fieldName = Text.pack $ selName @selector undefined
- prefix = applyFirst toLower $ Text.pack s
- scopedKey =
- case Text.stripPrefix prefix fieldName of
- Just stripped -> applyFirst toLower stripped
- Nothing -> fieldName
- in M1 <$> updateFromConfigG @inner (key /. Path [scopedKey]) config inner
-
--- | Purely 'Generics' machinery, ignore...
-instance (FetchFromConfig inner) => UpdateFromConfigG (Rec0 inner) where
- updateFromConfigG key config (K1 inner) = do
- fetch @inner key config
- >>= \case
- Just newInner -> return $ K1 newInner
- Nothing -> return $ K1 inner
diff --git a/src/Conferer/FromConfig/Basics.hs b/src/Conferer/FromConfig/Basics.hs
new file mode 100644
--- /dev/null
+++ b/src/Conferer/FromConfig/Basics.hs
@@ -0,0 +1,206 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Conferer.FromConfig.Basics where
+
+import Control.Monad (join)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.ByteString (ByteString)
+import Data.Maybe (fromMaybe)
+import Control.Exception
+import Data.Char (toLower)
+import Data.Typeable (Typeable, typeRep, Proxy(..))
+import Data.String (IsString, fromString)
+import Text.Read (readMaybe)
+import GHC.Generics
+
+import Conferer.Types
+import Conferer.Core (getKey, (/.), getFromConfig)
+
+updateAllAtOnceUsingFetch :: forall a. (FromConfig a, Typeable a) => Key -> Config -> a -> IO a
+updateAllAtOnceUsingFetch key config old = do
+ fetchFromConfig key config
+ >>= \case
+ Just new -> do
+ evaluate new
+ Nothing -> do
+ evaluate old
+
+instance FromConfig Int where
+ updateFromConfig = updateAllAtOnceUsingFetch
+ fetchFromConfig = fetchFromConfigByRead
+
+instance FromConfig Integer where
+ updateFromConfig = updateAllAtOnceUsingFetch
+ fetchFromConfig = fetchFromConfigByRead
+
+instance FromConfig Float where
+ updateFromConfig = updateAllAtOnceUsingFetch
+ fetchFromConfig = fetchFromConfigByRead
+
+instance FromConfig ByteString where
+ updateFromConfig = updateAllAtOnceUsingFetch
+ fetchFromConfig = fetchFromConfigWith (Just . Text.encodeUtf8)
+
+instance DefaultConfig (Maybe a) where
+ configDef = Nothing
+instance (FromConfig a) => FromConfig (Maybe a) where
+ updateFromConfig k config (Just a) = do
+ res <- updateFromConfig k config a
+ Just <$> evaluate res
+ updateFromConfig k config Nothing = do
+ fetchFromConfig k config
+ fetchFromConfig k config = do
+ fetchFromConfig @a k config
+ >>= \case
+ Just res -> Just <$> Just <$> evaluate res
+ Nothing -> return $ Just Nothing
+
+
+instance FromConfig String where
+ updateFromConfig = updateAllAtOnceUsingFetch
+ fetchFromConfig = fetchFromConfigWith (Just . Text.unpack)
+
+instance FromConfig Text where
+ updateFromConfig = updateAllAtOnceUsingFetch
+ fetchFromConfig = fetchFromConfigWith Just
+
+
+instance FromConfig Bool where
+ updateFromConfig = updateAllAtOnceUsingFetch
+ fetchFromConfig = fetchFromConfigWith parseBool
+
+parseBool text =
+ case Text.toLower text of
+ "false" -> Just False
+ "true" -> Just True
+ _ -> Nothing
+
+updateFromConfigByRead :: (Typeable a, Read a) => Key -> Config -> a -> IO (a)
+updateFromConfigByRead = updateFromConfigWith (readMaybe . Text.unpack)
+
+updateFromConfigByIsString :: (Typeable a, IsString a) => Key -> Config -> a -> IO (a)
+updateFromConfigByIsString = updateFromConfigWith (Just . fromString . Text.unpack)
+
+fetchFromConfigByRead :: (Typeable a, Read a) => Key -> Config -> IO (Maybe a)
+fetchFromConfigByRead = fetchFromConfigWith (readMaybe . Text.unpack)
+
+fetchFromConfigByIsString :: (Typeable a, IsString a) => Key -> Config -> IO (Maybe a)
+fetchFromConfigByIsString = fetchFromConfigWith (Just . fromString . Text.unpack)
+
+fromValueWith :: (Text -> Maybe a) -> Text -> Maybe a
+fromValueWith parseValue valueAsText = parseValue valueAsText
+
+fetchFromConfigWith :: forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO (Maybe a)
+fetchFromConfigWith parseValue key config = do
+ getKey key config >>=
+ \case
+ Just value ->
+ return $ Just $
+ fromMaybe (throw $ ConfigParsingError key value (typeRep (Proxy :: Proxy a))) $
+ fromValueWith parseValue value
+ Nothing ->
+ return Nothing
+
+updateFromConfigWith :: forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> a -> IO a
+updateFromConfigWith parseValue key config a = do
+ getKey key config >>=
+ \case
+ Just value ->
+ return $
+ fromMaybe (throw $ ConfigParsingError key value (typeRep (Proxy :: Proxy a))) $
+ fromValueWith parseValue value
+ Nothing -> return a
+
+-- | Concatenate many transformations to the config based on keys and functions
+findKeyAndApplyConfig ::
+ forall newvalue config.
+ FromConfig newvalue
+ => Config -- ^ Complete config
+ -> Key -- ^ Key that indicates the part of the config that we care about
+ -> Key -- ^ Key that we use to find the config (usually concatenating with the
+ -- other key)
+ -> (config -> newvalue) -- ^ Function that knows how to use the
+ -- value to update the config
+ -> (newvalue -> config -> config) -- ^ Function that knows how to use the
+ -- value to update the config
+ -> config -- ^ Result of the last config updating
+ -> IO config -- ^ Updated config
+findKeyAndApplyConfig config k relativeKey get set customConfig = do
+ newValue <- updateFromConfig @newvalue (k /. relativeKey) config (get customConfig)
+ return $ set newValue customConfig
+
+instance FromConfigG inner =>
+ FromConfigG (D1 metadata inner) where
+ updateFromConfigG key config (M1 inner) =
+ M1 <$> updateFromConfigG key config inner
+ fetchFromConfigG key config =
+ fmap M1 <$> fetchFromConfigG key config
+
+instance (FromConfigWithConNameG inner, Constructor constructor) =>
+ FromConfigG (C1 constructor inner) where
+ updateFromConfigG key config (M1 inner) =
+ M1 <$> updateFromConfigWithConNameG @inner (conName @constructor undefined) key config inner
+ fetchFromConfigG key config =
+ fmap M1 <$> fetchFromConfigWithConNameG @inner (conName @constructor undefined) key config
+
+class FromConfigWithConNameG f where
+ updateFromConfigWithConNameG :: String -> Key -> Config -> f a -> IO (f a)
+ fetchFromConfigWithConNameG :: String -> Key -> Config -> IO (Maybe (f a))
+
+instance (FromConfigWithConNameG left, FromConfigWithConNameG right) =>
+ FromConfigWithConNameG (left :*: right) where
+ updateFromConfigWithConNameG s key config (left :*: right) = do
+ leftValue <- updateFromConfigWithConNameG @left s key config left
+ rightValue <- updateFromConfigWithConNameG @right s key config right
+ return (leftValue :*: rightValue)
+
+ fetchFromConfigWithConNameG s key config = do
+ leftValue <- fetchFromConfigWithConNameG @left s key config
+ rightValue <- fetchFromConfigWithConNameG @right s key config
+ case (leftValue, rightValue) of
+ (Just l, Just r) -> return $ Just (l :*: r)
+ _ -> return Nothing
+
+instance (FromConfigG inner, Selector selector) =>
+ FromConfigWithConNameG (S1 selector inner) where
+ updateFromConfigWithConNameG s key config (M1 inner) =
+ let
+ applyFirst :: (Char -> Char) -> Text -> Text
+ applyFirst f t = case Text.uncons t of
+ Just (c, ts) -> Text.cons (f c) ts
+ Nothing -> t
+
+ fieldName = Text.pack $ selName @selector undefined
+ prefix = applyFirst toLower $ Text.pack s
+ scopedKey =
+ case Text.stripPrefix prefix fieldName of
+ Just stripped -> applyFirst toLower stripped
+ Nothing -> fieldName
+ in M1 <$> updateFromConfigG @inner (key /. Path [scopedKey]) config inner
+
+ fetchFromConfigWithConNameG s key config =
+ let
+ applyFirst :: (Char -> Char) -> Text -> Text
+ applyFirst f t = case Text.uncons t of
+ Just (c, ts) -> Text.cons (f c) ts
+ Nothing -> t
+
+ fieldName = Text.pack $ selName @selector undefined
+ prefix = applyFirst toLower $ Text.pack s
+ scopedKey =
+ case Text.stripPrefix prefix fieldName of
+ Just stripped -> applyFirst toLower stripped
+ Nothing -> fieldName
+ in fmap M1 <$> fetchFromConfigG @inner (key /. Path [scopedKey]) config
+
+-- | Purely 'Generics' machinery, ignore...
+instance (FromConfig inner) => FromConfigG (Rec0 inner) where
+ updateFromConfigG key config (K1 inner) = do
+ K1 <$> updateFromConfig @inner key config inner
+ fetchFromConfigG key config = do
+ fmap K1 <$> fetchFromConfig @inner key config
diff --git a/src/Conferer/Provider/Files.hs b/src/Conferer/Provider/Files.hs
--- a/src/Conferer/Provider/Files.hs
+++ b/src/Conferer/Provider/Files.hs
@@ -4,7 +4,7 @@
import Data.Maybe (fromMaybe)
import Conferer.Types
-import Conferer.FetchFromConfig.Basics ()
+import Conferer.FromConfig.Basics ()
fromRight :: a -> Either e a -> a
fromRight a (Left _) = a
@@ -12,7 +12,7 @@
getFilePathFromEnv :: Config -> String -> IO FilePath
getFilePathFromEnv config extension = do
- env <- fromMaybe "development" <$> fetch "env" config
+ env <- updateFromConfig "env" config "development"
return $ mconcat
[ "config/"
, Text.unpack env
diff --git a/src/Conferer/Types.hs b/src/Conferer/Types.hs
--- a/src/Conferer/Types.hs
+++ b/src/Conferer/Types.hs
@@ -49,45 +49,40 @@
-- needs connection info to connect to the server)
type ProviderCreator = Config -> IO Provider
--- | Main typeclass for defining the way to get values from config, hiding the
--- 'Text' based nature of the 'Provider's
+keyNotPresentError :: forall a. (Typeable a) => Key -> Proxy a -> FailedToFetchError
+keyNotPresentError key =
+ throw $ FailedToFetchError key $ typeRep (Proxy :: Proxy a)
+
+-- | Default defining instance
--
-- Here a 'Nothing' means that the value didn't appear in the config, some
-- instances never return a value since they have defaults that can never
-- fail
-class FetchFromConfig a where
- fetch :: Key -> Config -> IO (Maybe a)
- default fetch :: (DefaultConfig a, UpdateFromConfig a) => Key -> Config -> IO (Maybe a)
- fetch k config = Just <$> updateFromConfig k config configDef
-
--- | Here implementing this typeclass means that this type has some kind of default
--- that is both always valid and has always the same semantics, for example: Warp.Settings
--- has a default since it's always use in the same way (to configure a warp server)
--- but for example an Int could mean many things depending on the context so it doesn't
--- really make sense to implement it for it
---
--- It's also used for the 'Generic' implementation, if you have a Record made up from
--- types that implement 'FetchFromConfig' you can derive the 'FetchFromConfig' automatically
--- by implementing 'DefaultConfig' and deriving (using 'Generic') 'UpdateFromConfig'
class DefaultConfig a where
configDef :: a
--- | This class only exist for the 'Generics' machinery, it means that a value can get
+-- | Main typeclass for defining the way to get values from config, hiding the
+-- 'Text' based nature of the 'Provider's.
-- updated using a config, so for example a Warp.Settings can get updated from a config,
-- but that doesn't make much sense for something like an 'Int'
--
-- You'd normally would never implement this typeclass, if you want to implement
--- 'FetchFromConfig' you should implement that directly, and if you want to use
--- 'DefaultConfig' and 'UpdateFromConfig' to implement 'FetchFromConfig' you should let
+-- 'FromConfig' you should implement that directly, and if you want to use
+-- 'DefaultConfig' and 'FromConfig' to implement 'FromConfig' you should let
-- the default 'Generics' based implementation do it's thing
-class Typeable a => UpdateFromConfig a where
+class FromConfig a where
updateFromConfig :: Key -> Config -> a -> IO a
- default updateFromConfig :: (Generic a, UpdateFromConfigG (Rep a), DefaultConfig a) => Key -> Config -> a -> IO a
+ default updateFromConfig :: (Generic a, Typeable a, FromConfigG (Rep a)) => Key -> Config -> a -> IO a
updateFromConfig k c a = to <$> updateFromConfigG k c (from a)
+ fetchFromConfig :: Key -> Config -> IO (Maybe a)
+ default fetchFromConfig :: (Generic a, FromConfigG (Rep a)) => Key -> Config -> IO (Maybe a)
+ fetchFromConfig k c = fmap to <$> fetchFromConfigG k c
+
-- | Purely 'Generics' machinery, ignore...
-class UpdateFromConfigG f where
+class FromConfigG f where
updateFromConfigG :: Key -> Config -> f a -> IO (f a)
+ fetchFromConfigG :: Key -> Config -> IO (Maybe (f a))
data ConfigParsingError =
ConfigParsingError Key Text TypeRep
@@ -117,6 +112,7 @@
, show typeRep
, " from key '"
, Text.unpack (keyName key)
+ , "'"
]
instance Exception FailedToFetchError
diff --git a/test/Conferer/FetchFromConfig/BasicsSpec.hs b/test/Conferer/FetchFromConfig/BasicsSpec.hs
deleted file mode 100644
--- a/test/Conferer/FetchFromConfig/BasicsSpec.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-module Conferer.FetchFromConfig.BasicsSpec where
-
-import Test.Hspec
-import Conferer.Types
-import Data.Text
-import Conferer
-import Conferer.FetchFromConfig.Basics ()
-import Control.Exception (evaluate)
-import Data.Typeable
-import Control.DeepSeq
-
-configWith :: [(Key, Text)] -> IO Config
-configWith keyValues = emptyConfig & addProvider (mkMapProvider keyValues)
-
-configParserError_ :: ConfigParsingError -> Bool
-configParserError_ = const True
-
-configParserError :: Key -> ConfigParsingError -> Bool
-configParserError key (ConfigParsingError k _ _) =
- key == k
-
-spec :: Spec
-spec = context "Basics" $ do
- describe "fetching an Int from config" $ do
- it "getting a value that can't be parsed as an int returns an error message" $ do
- config <- configWith [ ("anInt", "50A") ]
- fetchedValue <- fetch @Int "anInt" config
-
- evaluate (force fetchedValue) `shouldThrow` configParserError_
- -- evaluate (force fetchedValue) `shouldThrow` anyErrorCall
-
- it "getting a value that can be parsed correctly returns the int" $ do
- config <- configWith [ ("anInt", "50") ]
- fetchedValue <- fetch @Int "anInt" config
- fetchedValue `shouldBe` Just 50
-
- describe "fetching a Bool from config" $ do
- it "getting a value that can't be parsed as a bool returns an error message" $ do
- config <- configWith [ ("aBool", "nope") ]
- fetchedValue <- fetch @Bool "aBool" config
- evaluate (force fetchedValue) `shouldThrow` configParserError_
-
- it "getting a value that can be parsed as a bool returns the bool" $ do
- config <- configWith [ ("aBool", "True"), ("anotherBool", "False") ]
- fetchedValue <- fetch "aBool" config
- fetchedValue `shouldBe` Just True
- anotherFetchedValue <- fetch "anotherBool" config
- anotherFetchedValue `shouldBe` Just False
-
- it "the parsing of the bool value is case insensitive" $ do
- config <- configWith [ ("aBool", "TRUE"), ("anotherBool", "fAlSe") ]
- fetchedValue <- fetch "aBool" config
- fetchedValue `shouldBe` Just True
- anotherFetchedValue <- fetch "anotherBool" config
- anotherFetchedValue `shouldBe` Just False
-
- describe "fetching a String from config" $ do
- it "getting a value returns the value as a string" $ do
- config <- configWith [ ("aString", "Bleh") ]
- fetchedValue <- fetch @String "aString" config
- fetchedValue `shouldBe` Just "Bleh"
-
- describe "fetching a Float from config" $ do
- it "if the value can be parsed as float, it returns that float" $ do
- config <- configWith [ ("aFloat", "9.5") ]
- fetchedValue <- fetch @Float "aFloat" config
- fetchedValue `shouldBe` Just 9.5
-
- it "if the value cannot be parsed as float, it fails" $ do
- config <- configWith [ ("aFloat", "ASD") ]
- fetchedValue <- fetch @Float "aFloat" config
- evaluate (force fetchedValue) `shouldThrow` configParserError_
-
- describe "fetching a String from config" $ do
- it "getting a value returns the value as a Just" $ do
- config <- configWith [ ("anInt", "17") ]
- fetchedValue <- fetch @(Maybe Int) "anInt" config
- fetchedValue `shouldBe` Just (Just 17)
- context "when the key is there but has a wrong value" $ do
- it "returns Nothing" $ do
- config <- configWith [ ("anInt", "Bleh") ]
- fetchedValue <- fetch @(Maybe Int) "anInt" config
- evaluate (force fetchedValue) `shouldThrow` configParserError_
- context "when the key is not there" $ do
- it "returns Nothing" $ do
- config <- configWith [ ]
- fetchedValue <- fetch @(Maybe Int) "anInt" config
- fetchedValue `shouldBe` Nothing
diff --git a/test/Conferer/FromConfig/BasicsSpec.hs b/test/Conferer/FromConfig/BasicsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Conferer/FromConfig/BasicsSpec.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Conferer.FromConfig.BasicsSpec where
+
+import Test.Hspec
+import Conferer.Types
+import Data.Text
+import Conferer
+import Control.Exception (evaluate)
+import Data.Typeable
+import Control.DeepSeq
+
+configWith :: [(Key, Text)] -> IO Config
+configWith keyValues = emptyConfig & addProvider (mkMapProvider keyValues)
+
+configParserError_ :: ConfigParsingError -> Bool
+configParserError_ = const True
+
+configParserError :: Key -> Text -> ConfigParsingError -> Bool
+configParserError key txt (ConfigParsingError k t _) =
+ key == k && t == txt
+
+fetch :: (FromConfig a, Show a, Typeable a) => Key -> Config -> IO (Maybe a)
+fetch = getFromConfig
+
+spec :: Spec
+spec = context "Basics" $ do
+ describe "fetching an Int from config" $ do
+ it "getting a value that can't be parsed as an int returns an error message" $ do
+ config <- configWith [ ("anInt", "50A") ]
+ fetch @Int "anInt" config `shouldThrow` configParserError "anInt" "50A"
+
+ it "getting a value that can be parsed correctly returns the int" $ do
+ config <- configWith [ ("anInt", "50") ]
+ fetchedValue <- fetch @Int "anInt" config
+ fetchedValue `shouldBe` Just 50
+
+ describe "fetching a Bool from config" $ do
+ it "getting a value that can't be parsed as a bool returns an error message" $ do
+ config <- configWith [ ("aBool", "nope") ]
+ fetch @Bool "aBool" config `shouldThrow` configParserError_
+
+ it "getting a value that can be parsed as a bool returns the bool" $ do
+ config <- configWith [ ("aBool", "True"), ("anotherBool", "False") ]
+ fetchedValue <- fetch "aBool" config
+ fetchedValue `shouldBe` Just True
+ anotherFetchedValue <- fetch "anotherBool" config
+ anotherFetchedValue `shouldBe` Just False
+
+ it "the parsing of the bool value is case insensitive" $ do
+ config <- configWith [ ("aBool", "TRUE"), ("anotherBool", "fAlSe") ]
+ fetchedValue <- fetch "aBool" config
+ fetchedValue `shouldBe` Just True
+ anotherFetchedValue <- fetch "anotherBool" config
+ anotherFetchedValue `shouldBe` Just False
+
+ describe "fetching a String from config" $ do
+ it "getting a value returns the value as a string" $ do
+ config <- configWith [ ("aString", "Bleh") ]
+ fetchedValue <- fetch @String "aString" config
+ fetchedValue `shouldBe` Just "Bleh"
+
+ describe "fetching a Float from config" $ do
+ it "if the value can be parsed as float, it returns that float" $ do
+ config <- configWith [ ("aFloat", "9.5") ]
+ fetchedValue <- fetch @Float "aFloat" config
+ fetchedValue `shouldBe` Just 9.5
+
+ it "if the value cannot be parsed as float, it fails" $ do
+ config <- configWith [ ("aFloat", "ASD") ]
+ fetch @Float "aFloat" config `shouldThrow` configParserError_
+
+ describe "fetching a String from config" $ do
+ context "when the key is there but has a wrong value" $ do
+ it "returns Nothing" $ do
+ config <- configWith [ ("anInt", "Bleh") ]
+ fetch @Int "anInt" config `shouldThrow` configParserError_
+ context "when the key is not there" $ do
+ it "returns Nothing" $ do
+ config <- configWith [ ]
+ fetchedValue <- fetch @Int "anInt" config
+ fetchedValue `shouldBe` Nothing
+ it "returns Nothing" $ do
+ config <- configWith [ ]
+ fetchedValue <- fetch @(Maybe Int) "anInt" config
+ fetchedValue `shouldBe` Just Nothing
diff --git a/test/Conferer/GenericsSpec.hs b/test/Conferer/GenericsSpec.hs
--- a/test/Conferer/GenericsSpec.hs
+++ b/test/Conferer/GenericsSpec.hs
@@ -5,29 +5,31 @@
import Test.Hspec
import Conferer
-import Conferer.Types (UpdateFromConfig, DefaultConfig, configDef)
+import Conferer.Types (FromConfig, DefaultConfig, configDef)
+import Data.Typeable
import GHC.Generics
+fetch :: (FromConfig a, Show a, Typeable a, DefaultConfig a) => Key -> Config -> IO a
+fetch k c = getFromConfig k c
+
data Thing = Thing
{ thingA :: Int
, thingB :: Int
} deriving (Generic, Show, Eq)
-instance UpdateFromConfig Thing
+instance FromConfig Thing
instance DefaultConfig Thing where
configDef = Thing 0 0
-instance FetchFromConfig Thing
data Bigger = Bigger
{ biggerThing :: Thing
, biggerB :: Int
} deriving (Generic, Show, Eq)
-instance UpdateFromConfig Bigger
+instance FromConfig Bigger
instance DefaultConfig Bigger where
- configDef = Bigger configDef 1
-instance FetchFromConfig Bigger
+ configDef = Bigger (configDef { thingA = 27}) 1
spec :: Spec
spec = do
@@ -39,66 +41,66 @@
& addProvider (mkMapProvider [ ])
res <- fetch @Thing "somekey" c
- res `shouldBe` Just Thing { thingA = 0, thingB = 0 }
+ res `shouldBe` Thing { thingA = 0, thingB = 0 }
context "when all keys are set" $ do
it "return the keys set" $ do
c <- emptyConfig
- & addProvider (mkMapProvider
+ & addProvider (mkMapProvider
[ ("somekey.a", "1")
, ("somekey.b", "2")
])
res <- fetch @Thing "somekey" c
- res `shouldBe` Just Thing { thingA = 1, thingB = 2 }
+ res `shouldBe` Thing { thingA = 1, thingB = 2 }
context "when some keys are set" $ do
it "uses the default and returns the keys set" $ do
c <- emptyConfig
- & addProvider (mkMapProvider
+ & addProvider (mkMapProvider
[ ("somekey.b", "2")
])
res <- fetch @Thing "somekey" c
- res `shouldBe` Just Thing { thingA = 0, thingB = 2 }
+ res `shouldBe` Thing { thingA = 0, thingB = 2 }
context "with a nested record" $ do
context "when none of the keys are set" $ do
it "returns the default of both records" $ do
c <- emptyConfig
- & addProvider (mkMapProvider
+ & addProvider (mkMapProvider
[ ])
res <- fetch @Bigger "somekey" c
- res `shouldBe` Just Bigger { biggerThing = Thing { thingA = 0, thingB = 0 }, biggerB = 1}
+ res `shouldBe` Bigger { biggerThing = Thing { thingA = 27, thingB = 0 }, biggerB = 1}
context "when some keys of the top record are set" $ do
it "returns the default for the inner record" $ do
c <- emptyConfig
- & addProvider (mkMapProvider
+ & addProvider (mkMapProvider
[ ("somekey.b", "30")
])
res <- fetch @Bigger "somekey" c
- res `shouldBe` Just Bigger { biggerThing = Thing { thingA = 0, thingB = 0 }, biggerB = 30}
+ res `shouldBe` Bigger { biggerThing = Thing { thingA = 27, thingB = 0 }, biggerB = 30}
context "when some keys of the inner record are set" $ do
it "returns the inner record updated" $ do
c <- emptyConfig
- & addProvider (mkMapProvider
+ & addProvider (mkMapProvider
[ ("somekey.thing.a", "30")
])
res <- fetch @Bigger "somekey" c
- res `shouldBe` Just Bigger { biggerThing = Thing { thingA = 30, thingB = 0 }, biggerB = 1}
+ res `shouldBe` Bigger { biggerThing = Thing { thingA = 30, thingB = 0 }, biggerB = 1}
context "when every key is set" $ do
it "returns everything with the right values" $ do
c <- emptyConfig
- & addProvider (mkMapProvider
+ & addProvider (mkMapProvider
[ ("somekey.thing.a", "10")
, ("somekey.thing.b", "20")
, ("somekey.b", "30")
])
res <- fetch @Bigger "somekey" c
- res `shouldBe` Just Bigger { biggerThing = Thing { thingA = 10, thingB = 20 }, biggerB = 30}
+ res `shouldBe` Bigger { biggerThing = Thing { thingA = 10, thingB = 20 }, biggerB = 30}