diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,49 @@ +# Changelog +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to [PVP](https://pvp.haskell.org/). + +## [Unreleased] + +Nothing + +## [v1.1.0.0] - 2021-03-01 + +### Changed + +* Rename `fromFilePath` to `fromFilePath'`. +* Define a new `fromFilePath` whose type is `FilePath -> SourceCreator` instaed of `FilePath -> IO Source`. +* (Internal) Remove the mismatched type exception since it's not actionable by the user +* (Internal) Use a list for default values so that many different defaults are available, + possible point of extension in the future. +* Constraint valid key names to lowercase ascii and numbers (previously some non ascii characters were allowed) + +### Added + +* `isValidKeyFragment` and `isKeyCharacter` to validate `Key`s +* Added an overriding method based on type and key (details in the docs) + +## [v1.0.0.1] - 2021-01-17 + +### Fixed + +* In the `File`'s `FromConfig` instance, if the default is present and it's type +is `File`, it throws, which doesn't follow the rest of the library. + +### Added + +* Add `mkConfig'` which allows creating a config by passing a list of defaults and +a list of source creators. +* Add `addSources`, which allows to add several sources to a config. +* Define the type `Defaults`, which is a list of associations from `Key` to +`Dynamic`. + +## [v1.0.0.0] - 2020-12-29 + +First release + +[Unreleased]: https://github.com/ludat/conferer/compare/conferer_v1.1.0.0...HEAD +[v1.1.0.0]: https://github.com/ludat/conferer/releases/tag/conferer_v1.0.0.1...conferer_v1.1.0.0 +[v1.0.0.1]: https://github.com/ludat/conferer/releases/tag/conferer_v1.0.0.0...conferer_v1.0.0.1 +[v1.0.0.0]: https://github.com/ludat/conferer/releases/tag/v0.0.0.0...conferer_v1.0.0.0 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: 41b921ef11b0981ed712b7e72a531f123613815eb7b3ebe4f9e0778a998118c6 +-- hash: 80fdd520360a49e55b6dfe3ff9e148c716a7af0b6cf3d0326f8ed3d4a8f67611 name: conferer -version: 0.4.1.1 +version: 1.1.0.0 synopsis: Configuration management library description: Library to abstract the parsing of many haskell config values from different config sources @@ -15,65 +15,91 @@ homepage: https://conferer.ludat.io author: Lucas David Traverso maintainer: lucas6246@gmail.com +copyright: (c) 2020 Lucas David Traverso license: MPL-2.0 license-file: LICENSE build-type: Simple extra-doc-files: README.md + CHANGELOG.md LICENSE library exposed-modules: Conferer - Conferer.Core - Conferer.FromConfig.Basics + Conferer.Config + Conferer.Config.Internal + Conferer.Config.Internal.Types + Conferer.FromConfig + Conferer.FromConfig.Internal + Conferer.Key + Conferer.Key.Internal + Conferer.Source Conferer.Source.CLIArgs Conferer.Source.Env Conferer.Source.Files - Conferer.Source.Mapping + Conferer.Source.InMemory + Conferer.Source.Internal Conferer.Source.Namespaced Conferer.Source.Null Conferer.Source.PropertiesFile - Conferer.Source.Simple - Conferer.Types + Conferer.Test other-modules: Paths_conferer hs-source-dirs: src - default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables + default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables RecordWildCards StrictData + ghc-options: -Wall -Wredundant-constraints -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns build-depends: base >=4.3 && <5 , bytestring >=0.10 && <0.11 , containers >=0.5 && <0.7 , directory >=1.2 && <2.0 + , filepath >=1.0 && <2.0 , text >=1.1 && <1.3 + if impl(ghc >= 8.4.1) + ghc-options: -Wpartial-fields default-language: Haskell2010 test-suite specs type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: ConfererSpecMain.hs other-modules: - Conferer.FromConfig.BasicsSpec + Conferer.ConfigSpec + Conferer.FromConfig.BoolSpec + Conferer.FromConfig.Extended + Conferer.FromConfig.FileSpec + Conferer.FromConfig.ListSpec + Conferer.FromConfig.MaybeSpec + Conferer.FromConfig.NumbersSpec + Conferer.FromConfig.StringLikeSpec + Conferer.FromConfigSpec Conferer.GenericsSpec - Conferer.Source.ArgsSpec + Conferer.KeySpec + Conferer.Source.CLIArgsSpec Conferer.Source.EnvSpec - Conferer.Source.MappingSpec + Conferer.Source.InMemorySpec Conferer.Source.NamespacedSpec Conferer.Source.NullSpec Conferer.Source.PropertiesFileSpec - Conferer.Source.SimpleSpec ConfererSpec + Spec Paths_conferer hs-source-dirs: test - default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables + default-extensions: OverloadedStrings LambdaCase QuasiQuotes ScopedTypeVariables RecordWildCards StrictData + ghc-options: -Wall -Wredundant-constraints -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -main-is ConfererSpecMain build-depends: - base >=4.3 && <5 + QuickCheck + , base >=4.3 && <5 , bytestring >=0.10 && <0.11 , conferer , containers >=0.5 && <0.7 , deepseq , directory >=1.2 && <2.0 + , filepath >=1.0 && <2.0 , hspec , text >=1.1 && <1.3 + if impl(ghc >= 8.4.1) + ghc-options: -Wpartial-fields default-language: Haskell2010 diff --git a/src/Conferer.hs b/src/Conferer.hs --- a/src/Conferer.hs +++ b/src/Conferer.hs @@ -1,117 +1,92 @@ -{-# LANGUAGE DeriveGeneric #-} -- | --- Module: Conferer --- Copyright: (c) 2019 Lucas David Traverso --- License: MIT --- Maintainer: Lucas David Traverso --- Stability: experimental +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable -- Portability: portable -- --- Types and functions for managing configuration effectively +-- Public and stable API for the most basic usage of this library module Conferer ( - -- * How to use this library - -- | This is the most basic example: which uses the default configuration - -- to get a configuration for warp, which can be overriden via env vars, - -- command line arguments of @.properties@ files - -- - -- @ - -- import Conferer - -- import Conferer.FromConfig.Warp () -- from package conferer-warp - -- - -- main = do - -- config <- 'defaultConfig' \"awesomeapp\" - -- warpSettings <- 'getFromConfig' \"warp\" config - -- runSettings warpSettings application - -- @ - -- - -- In the above example we see that we are getting a configuration value for - -- warp under the key warp, so for example to override it's default value - -- provided by warp the config keys for warp will always look like - -- @warp.something@, for example to override the port for warp (3000 by - -- default) we could call our program as @./my_program --warp.port=8000@. - -- - -- There are two sides to conferer: Getting configuration for other libraries - -- like warp, hspec, snap, etc. and the way we choose to provide values like - -- json files, properties files, env vars, etc. + -- * How to use this doc + -- | This doc is mostly for reference, so you probably won't learn how to + -- use conferer by reading it. For more detailed and guided documentation + -- the best place is the webpage: - -- ** Getting configuration for existing libraries - -- | 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 ( - -- for example: conferer-snap, conferer-warp, conferer-hspec), if you find - -- a library without a conferer port for its config you can create an issue - -- or maybe even create the library yourself! + -- * Creating a Config + mkConfig + , mkConfig' + -- * Getting values from a config + -- | These functions allow you to get any type that implements 'FromConfig' + , fetch + , fetch' + , fetchKey + , fetchFromConfig + , safeFetchKey + , unsafeFetchKey + , DefaultConfig(..) + , FromConfig + -- * Some useful types + , Config + , Key + ) where - -- ** 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 'FromConfig' (like - -- 'Warp.Settings') - -- - -- Internally a 'Config' is made of many 'Source's which have a simpler - -- interface: - -- - -- @ - -- 'getKeyInSource' :: Source -> Key -> IO (Maybe Text) - -- @ - -- - -- Most configuration sources can be abstracted away as Map String String, - -- and they can use whatever logic they want to turn conferer keys (a list of - -- strings) into a place to look for a string, (for example the env source - -- requires a string to namespace the env vars that can affect the - -- configuration) - -- - -- Once you have your 'Source' you can add it to a 'Config' using the - -- 'addSource' function. One final note: each source has a different - -- priority, which depends on when is was added to the config ('Source's - -- added later have lower priority) so the config searches keys in sources - -- in the same order they were added. +import Data.Text (Text) +import Data.Typeable (Typeable) - module Conferer.Types - , module Conferer.Core - , defaultConfig - , defaultConfigWithDefaults - , Key(..) +import Conferer.Config.Internal +import Conferer.Config.Internal.Types +import Conferer.FromConfig.Internal +import Conferer.Key +import qualified Conferer.Source.Env as Env +import qualified Conferer.Source.CLIArgs as Cli +import qualified Conferer.Source.PropertiesFile as PropertiesFile +import Conferer.Config (Defaults) - -- * Sources - , module Conferer.Source.Env - , module Conferer.Source.Simple - , module Conferer.Source.Namespaced - , module Conferer.Source.Mapping - , module Conferer.Source.CLIArgs - , module Conferer.Source.Null - , module Conferer.Source.PropertiesFile - -- * Re-Exports - , (&) - ) where +-- | Use the 'FromConfig' instance to get a value of type @a@ from the config +-- using some default fallback. The most common use for this is creating a custom +-- record and using this function to fetch it at initialization time. +-- +-- This function throws only parsing exceptions when the values are present +-- but malformed somehow (@"abc"@ as an Int) but that depends on the 'FromConfig' +-- implementation for the type. +fetch :: forall a. (FromConfig a, Typeable a, DefaultConfig a) => Config -> IO a +fetch c = fetchFromRootConfigWithDefault c configDef -import Data.Text (Text) -import Data.Function ((&)) +-- | Same as 'fetch' but it accepts the default as a parameter instead of using +-- the default from 'configDef' +fetch' :: forall a. (FromConfig a, Typeable a) => Config -> a -> IO a +fetch' = fetchFromRootConfigWithDefault -import Conferer.Core (emptyConfig, addSource, getFromConfig, getFromRootConfig, getFromConfigWithDefault, safeGetFromConfig, safeGetFromConfigWithDefault, getKey, unsafeGetKey, (/.), withDefaults) -import Conferer.Types (Config, Key(..), SourceCreator, Source(..), DefaultConfig(..), FromConfig(..)) -import Conferer.Source.Env -import Conferer.Source.Simple -import Conferer.Source.Namespaced -import Conferer.Source.Mapping -import Conferer.Source.CLIArgs -import Conferer.Source.Null -import Conferer.Source.PropertiesFile +-- | Same as 'fetch'' but you can specify a 'Key' instead of the root key which allows +-- you to fetch smaller values when you need them instead of a big one at +-- initialization time. +fetchKey :: forall a. (FromConfig a, Typeable a) => Config -> Key -> a -> IO a +fetchKey = fetchFromConfigWithDefault --- | Default config which reads from command line arguments, env vars and --- property files -defaultConfig :: Text -> IO Config -defaultConfig appName = - defaultConfigWithDefaults appName [] +-- | Same as 'fetchKey' but it returns a 'Nothing' when the value isn't present +safeFetchKey :: forall a. (FromConfig a, Typeable a) => Config -> Key -> IO (Maybe a) +safeFetchKey c k = fetchFromConfig k c --- | Default config which reads from command line arguments, env vars, --- property files and some default key/values -defaultConfigWithDefaults :: Text -> [(Key, Text)] -> IO Config -defaultConfigWithDefaults appName configMap = - pure (emptyConfig & withDefaults configMap) - >>= addSource (mkCLIArgsSource) - >>= addSource (mkEnvSource appName) - >>= addSource (mkPropertiesFileSource) +-- | Same as 'fetchKey' but it throws when the value isn't present. +unsafeFetchKey :: forall a. (FromConfig a, Typeable a) => Config -> Key -> IO a +unsafeFetchKey c k = fetchFromConfig k c + +-- | Create a 'Config' which reads from command line arguments, env vars and +-- property files that depend on the environment (@config/development.properties@) +-- by default +mkConfig :: Text -> IO Config +mkConfig appName = + pure emptyConfig + >>= addSource (Cli.fromConfig) + >>= addSource (Env.fromConfig appName) + >>= addSource (PropertiesFile.fromConfig "config.file") + +-- | Create a 'Config' with the given defaults and source creators. +-- The sources will take precedence by the order they have in the list (earlier in +-- the list means it's tried first). +-- If the requested key is not found in any source it'll be looked up in the defaults. +mkConfig' :: Defaults -> [SourceCreator] -> IO Config +mkConfig' defaults sources = addSources sources . addDefaults defaults $ emptyConfig diff --git a/src/Conferer/Config.hs b/src/Conferer/Config.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Config.hs @@ -0,0 +1,37 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Public API providing Config functionality +module Conferer.Config + ( + -- * Data + Config + -- * Querying a config + , getKey + , KeyLookupResult(..) + , listSubkeys + -- * Config creation and initialization + , emptyConfig + , addSource + , addSources + , addDefault + , addDefaults + , addKeyMappings + , removeDefault + , Defaults + -- * Re-Exports + , module Conferer.Key + , (&) + ) where + +import Conferer.Config.Internal +import Conferer.Config.Internal.Types +import Conferer.Key +import Data.Function +import Data.Dynamic (Dynamic) + +type Defaults = [(Key, Dynamic)] diff --git a/src/Conferer/Config/Internal.hs b/src/Conferer/Config/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Config/Internal.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE TypeApplications #-} +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: unstable +-- Portability: portable +-- +-- Internal module providing Config functionality +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Conferer.Config.Internal where + +import Control.Monad (foldM, forM, msum) +import Data.Dynamic +import Data.List (sort, nub, union) +import Data.Text (Text) +import Data.Maybe (isJust) +import qualified Data.Map as Map + +import Conferer.Key +import Conferer.Source.Internal +import Conferer.Config.Internal.Types + +-- | This function runs lookups on the 'Config', first in 'Source's in order and +-- then on the 'Dynamic' based defaults. +getKey :: Key -> Config -> IO KeyLookupResult +getKey key config = do + let possibleKeys = getKeysFromMappings (configKeyMappings config) key + untilJust (fmap (\MappedKey{..} -> getRawKeyInSources mappedKey config) possibleKeys) + >>= \case + Just (k, textResult) -> + return $ FoundInSources k textResult + Nothing -> + case msum $ fmap (\MappedKey{..} -> fmap (mappedKey,) $ (getKeyFromDefaults mappedKey config)) possibleKeys of + Just (k, dynResult) -> return $ FoundInDefaults k dynResult + Nothing -> return $ MissingKey [key] + +-- | Alias for a mapping from one key to another used for transforming keys +type KeyMapping = (Key, Key) + +-- | A key that has been transformed using one or many 'KeyMapping's, so that +-- that process can be reversed. +data MappedKey = MappedKey + { mappingsChain :: [KeyMapping] + , mappedKey :: Key + } deriving (Show, Eq) + + +-- | This function lists all available keys under some key, that could be fetched +-- successfully. +listSubkeys :: Key -> Config -> IO [Key] +listSubkeys originalKey Config{..} = do + let mappedKeys = getKeysFromMappings configKeyMappings originalKey + subkeysFromSources <- forM mappedKeys $ \MappedKey{..} -> do + subkeysFromSources <- listRawSubkeysInSources mappedKey configSources + let subkeysFromDefaults = + filter (mappedKey `isKeyPrefixOf`) $ Map.keys configDefaults + return $ fmap (MappedKey mappingsChain) $ subkeysFromSources ++ subkeysFromDefaults + let subkeys = mconcat subkeysFromSources + return $ sort $ nub $ fmap undoMappings subkeys + +-- | This function lists subkeys in some 'Source's and combines the results +listRawSubkeysInSources :: Key -> [Source] -> IO [Key] +listRawSubkeysInSources mappedKey configSources = go mappedKey [] configSources + where + go :: Key -> [Key] -> [Source] -> IO [Key] + go _ result [] = return result + go k result (source:otherSources) = do + subkeys <- getSubkeysInSource source k + go k (result `union` subkeys) otherSources + +-- | This function reverses the mappings in a 'MappedKey' to retrieve the +-- original key. +-- +-- Assumes that mappings were really used, otherwise it ignores bad values +undoMappings :: MappedKey -> Key +undoMappings MappedKey{..} = + go (reverse mappingsChain) mappedKey + where + go [] key = key + go ((src, dest):others) key = + case stripKeyPrefix dest key of + Just k -> go others (src /. k) + Nothing -> go others key + +-- | This utility function run a list of IO actions and returns the +-- first that return a 'Just', if no one does, returns 'Nothing' +untilJust :: [IO (Maybe a)] -> IO (Maybe a) +untilJust actions = go actions + where + go [] = return Nothing + go (action:rest) = do + action + >>= \case + Just res -> return $ Just res + Nothing -> go rest + +-- | This function tries to apply a list of mappings to a key meaning +-- replace the prefix with the new value from the mapping, if the mapping +-- isn't a prefix that mapping is ignored +-- +-- This function always terminates even in presence of recursive mappings, +-- since it removes the mapping after it was first used, and that causes that +-- eventually the function will run out of keymappings and terminate. +getKeysFromMappings :: [KeyMapping] -> Key -> [MappedKey] +getKeysFromMappings originalKeyMappings originalKey = + go (MappedKey [] originalKey) originalKeyMappings + where + go :: MappedKey -> [KeyMapping] -> [MappedKey] + go k [] = [k] + go currKey keyMappings = + nub $ + currKey : + mconcat ( + fmap generateDerivedKeys $ + findAndSplitList tryMappingKey + keyMappings) + where + tryMappingKey :: (Key, Key) -> Maybe MappedKey + tryMappingKey (source, dest) = + case stripKeyPrefix source (mappedKey currKey) of + Just aKey -> + Just $ MappedKey (mappingsChain currKey ++ [(source, dest)]) (dest /. aKey) + Nothing -> Nothing + generateDerivedKeys :: ([KeyMapping], MappedKey, [KeyMapping]) -> [MappedKey] + generateDerivedKeys (prevMappings, aKey, nextMappings) = + go aKey $ prevMappings ++ nextMappings + +-- | This utility function splits a list based on a @cond@ function and returns a tuple +-- of previous value, next values and the mapped found value. +findAndSplitList :: forall a b. (a -> Maybe b) -> [a] -> [([a], b, [a])] +findAndSplitList cond list = go [] list + where + go :: [a] -> [a] -> [([a], b, [a])] + go _ [] = [] + go prevElems (curElem:nextElems) = + case cond curElem of + Just res -> + (prevElems, res, nextElems) : go (curElem:prevElems) nextElems + Nothing -> + go (curElem:prevElems) nextElems + +-- | This function gets a value from 'Source's but ignores mappings and defaults +getRawKeyInSources :: Key -> Config -> IO (Maybe (Key, Text)) +getRawKeyInSources k Config{..} = + go configSources + where + go [] = return Nothing + go (source:otherSources) = do + res <- getKeyInSource source k + case res of + Just t -> return $ Just (k, t) + Nothing -> go otherSources + +-- | This function gets values from the defaults +getKeyFromDefaults :: Key -> Config -> Maybe [Dynamic] +getKeyFromDefaults key Config{..} = + let + possibleKeys = fmap mappedKey $ getKeysFromMappings configKeyMappings key + in msum $ fmap (\k -> Map.lookup k configDefaults) possibleKeys + +-- | The empty configuration, this 'Config' is used as the base for +-- most config creating functions. +emptyConfig :: Config +emptyConfig = Config + { configSources = [] + , configDefaults = Map.empty + , configKeyMappings = [] + } + +-- | This function adds some key mappings to a 'Config' +addKeyMappings :: [KeyMapping] -> Config -> Config +addKeyMappings keyMappings config = + config + { configKeyMappings = configKeyMappings config ++ keyMappings + } + +-- | This function adds defaults to a 'Config' +addDefaults :: [(Key, Dynamic)] -> Config -> Config +addDefaults configMap config = + let + constructedMap = + Map.fromListWith (++) + . fmap (\(k,v) -> (k, [v])) + $ configMap + in config + { configDefaults = + Map.unionWith (++) constructedMap + $ configDefaults config + } + +-- | This function removes a default from a 'Config', this is the +-- oposite of 'addDefault', it deletes the first element of +-- matching type in a certain 'Key'. +removeDefault :: forall t. Typeable t => Key -> Config -> Config +removeDefault key config = + config + { configDefaults = + Map.update removeFirstDynamic key $ configDefaults config + } + where + removeFirst :: (a -> Bool) -> [a] -> [a] + removeFirst _ [] = [] + removeFirst condition (x:xs) = + if condition x + then xs + else x : removeFirst condition xs + + removeFirstDynamic :: [Dynamic] -> Maybe [Dynamic] + removeFirstDynamic dynamics = + let result = removeFirst (isJust . fromDynamic @t) dynamics + in if null result + then Nothing + else Just result + +-- | This function adds one default of a custom type to a 'Config' +-- +-- Note that unlike 'addDefaults' this function does the toDyn so +-- no need to do it on the user's side +addDefault :: (Typeable a) => Key -> a -> Config -> Config +addDefault key value config = + config + { configDefaults = Map.insertWith (++) key [toDyn value] $ configDefaults config + } + +-- | Instantiate a 'Source' using an 'SourceCreator' and a 'Config' and add +-- to the config +addSource :: SourceCreator -> Config -> IO Config +addSource mkSource config = do + newSource <- mkSource config + return $ + config + { configSources = configSources config ++ [ newSource ] + } + +-- | Instantiate several 'Source's using a 'SourceCreator's and a 'Config' and add +-- them to the config in the order defined by the list +addSources :: [SourceCreator] -> Config -> IO Config +addSources sources config = foldM (flip addSource) config sources + +-- orElse :: IO KeyLookupResult -> IO KeyLookupResult -> IO KeyLookupResult +-- orElse getKey1 getKey2 = do +-- result1 <- getKey1 +-- case result1 of +-- MissingKey _ -> getKey2 +-- FoundInSources _ _ -> return result1 +-- FoundInDefaults _ _ -> do +-- result2 <- getKey2 +-- case result2 of +-- MissingKey _ -> return result1 +-- FoundInSources _ _ -> return result2 +-- FoundInDefaults _ _ -> return result1 diff --git a/src/Conferer/Config/Internal/Types.hs b/src/Conferer/Config/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Config/Internal/Types.hs @@ -0,0 +1,38 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: unstable +-- Portability: portable +-- +-- Core types for Config (here because of depedency cycles) +module Conferer.Config.Internal.Types where + +import Data.Map (Map) +import Conferer.Key (Key) +import Data.Dynamic ( Dynamic ) +import Conferer.Source.Internal (Source) +import Data.Text (Text) + +-- | This type acts as the entry point for most of the library, it's main purpouse +-- is to expose a uniform interface into multiple configuration sources (such as +-- env vars, cli args, and many others including use defined ones using the +-- 'Source' interface) +data Config = + Config + { configSources :: [Source] + , configDefaults :: Map Key [Dynamic] + , configKeyMappings :: [(Key, Key)] + } deriving (Show) + +-- | Result of a key lookup in a 'Config' +data KeyLookupResult + = MissingKey [Key] + | FoundInSources Key Text + | FoundInDefaults Key [Dynamic] + deriving (Show) + +-- | The type for creating a source given a 'Config', some sources require a +-- certain configuration to be initialized (for example: the redis source +-- needs connection info to connect to the server) +type SourceCreator = Config -> IO Source diff --git a/src/Conferer/Core.hs b/src/Conferer/Core.hs deleted file mode 100644 --- a/src/Conferer/Core.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} -module Conferer.Core where - -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Typeable (Typeable, Proxy(..), typeRep) -import Control.Exception (try, throw, throwIO, evaluate) - -import Conferer.Source.Simple -import Conferer.Types - --- | Most Basic function to interact directly with a 'Config'. It always returns --- 'Text' in the case of success and implements the logic to traverse --- sources inside the 'Config'. -getKey :: Key -> Config -> IO (Maybe Text) -getKey k config = - go $ sources config ++ [mkPureMapSource (defaults config)] - where - go [] = return Nothing - go (source:sources) = do - res <- getKeyInSource source k - case res of - Just t -> return $ Just t - Nothing -> go sources - - --- | 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'. --- --- 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 = - 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 -parent /. child = Path (unKey parent ++ unKey child) - --- | The empty configuration, this 'Config' is used as the base for --- most config creating functions. -emptyConfig :: Config -emptyConfig = Config [] Map.empty - -withDefaults :: [(Key, Text)] -> Config -> Config -withDefaults configMap config = - config { defaults = Map.fromList configMap } - --- | Instantiate a 'SourceCreator' using the 'emptyConfig' -mkStandaloneSource :: SourceCreator -> IO Source -mkStandaloneSource mkSource = - mkSource emptyConfig - - --- | Instantiate a 'Source' using an 'SourceCretor' and a 'Config' and add --- to the config -addSource :: SourceCreator -> Config -> IO Config -addSource mkSource config = do - newSource <- mkSource config - return $ - config - { sources = sources config ++ [ newSource ] - } - --- | Same as 'getKey' but it throws if the 'Key' isn't found -unsafeGetKey :: Key -> Config -> IO Text -unsafeGetKey key config = - fromMaybe (throw $ FailedToFetchError key (typeRep (Proxy :: Proxy Text))) - <$> getKey key config diff --git a/src/Conferer/FromConfig.hs b/src/Conferer/FromConfig.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/FromConfig.hs @@ -0,0 +1,43 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Public API module providing FromConfig functionality +module Conferer.FromConfig + ( FromConfig(fromConfig) + , fetchFromConfig + , DefaultConfig(configDef) + , fetchFromConfigWithDefault + , fetchFromRootConfig + , fetchFromRootConfigWithDefault + + , fetchFromConfigByIsString + , fetchFromConfigByRead + , fetchFromConfigWith + , addDefaultsAfterDeconstructingToDefaults + + , MissingRequiredKey + , throwMissingRequiredKey + , missingRequiredKey + + , ConfigParsingError + , throwConfigParsingError + , configParsingError + + , Key + , (/.) + , File(..) + , KeyLookupResult(..) + , OverrideFromConfig(..) + , overrideFetch + + , fetchFromDefaults + , fetchRequiredFromDefaults + ) where + +import Conferer.FromConfig.Internal +import Conferer.Config.Internal.Types +import Conferer.Key diff --git a/src/Conferer/FromConfig/Basics.hs b/src/Conferer/FromConfig/Basics.hs deleted file mode 100644 --- a/src/Conferer/FromConfig/Basics.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# 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 () where - updateFromConfig key config _ = do - return () - fetchFromConfig key config = do - return $ Just () - -instance DefaultConfig () where - configDef = () - -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/FromConfig/Internal.hs b/src/Conferer/FromConfig/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/FromConfig/Internal.hs @@ -0,0 +1,486 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: unstable +-- Portability: portable +-- +-- Internal module providing FromConfig functionality +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Conferer.FromConfig.Internal where + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Control.Exception +import Data.Typeable +import Text.Read (readMaybe) +import Data.Dynamic +import GHC.Generics +import Data.Function ((&)) + +import Conferer.Key +import Conferer.Config.Internal.Types +import Conferer.Config.Internal +import qualified Data.Char as Char +import Control.Monad (forM) +import Data.Maybe (fromMaybe, mapMaybe) +import qualified System.FilePath as FilePath +import Data.List (nub, foldl', sort) +import Data.String (IsString(..)) +import Data.Foldable (msum) + +-- | The typeclass for defining the way to get values from a 'Config', hiding the +-- 'Text' based nature of the 'Conferer.Source.Source's and parse whatever value +-- as the types sees fit +-- +-- Some of these instances are provided in different packages to avoid the heavy +-- dependencies. +-- +-- It provides a reasonable default using 'Generic's so most of the time user need +-- not to implement this typeclass. +class FromConfig a where + -- | This function uses a 'Config' and a scoping 'Key' to get a value. + -- + -- Some conventions: + -- + -- * When some 'Key' is missing this function should throw 'MissingRequiredKey' + -- + -- * For any t it should hold that @fetchFromConfig k (config & addDefault k t) == t@ + -- meaning that a default on the same key with the right type should be used as a + -- default and with no configuration that value should be returned + -- + -- * Try desconstructing the value in as many keys as possible since is allows easier + -- partial overriding. + fromConfig :: Key -> Config -> IO a + default fromConfig :: (Typeable a, Generic a, IntoDefaultsG (Rep a), FromConfigG (Rep a)) => Key -> Config -> IO a + fromConfig key config = do + let configWithDefaults = case fetchFromDefaults @a key config of + Just d -> config & addDefaults (intoDefaultsG key $ from d) + Nothing -> config + to <$> fromConfigG key configWithDefaults + +fetchFromConfig :: forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a +fetchFromConfig key config = + case fetchFromDefaults @(OverrideFromConfig a) key config of + Just (OverrideFromConfig fetch) -> + fetch key $ removeDefault @(OverrideFromConfig a) key config + Nothing -> + fromConfig key config + +-- | Utility only typeclass to smooth the naming differences between default values for +-- external library settings +-- +-- This typeclass is not used internally it's only here for convinience for users +class DefaultConfig a where + configDef :: a + +instance {-# OVERLAPPABLE #-} Typeable a => FromConfig a where + fromConfig = fetchRequiredFromDefaults + +instance FromConfig () where + fromConfig _key _config = return () + +instance FromConfig String where + fromConfig = fetchFromConfigWith (Just . Text.unpack) + +instance {-# OVERLAPPABLE #-} (Typeable a, FromConfig a) => + FromConfig [a] where + fromConfig key config = do + keysForItems <- getSubkeysForItems + case keysForItems of + Nothing -> do + fetchRequiredFromDefaults @[a] key config + Just subkeys -> do + let configWithDefaults :: Config = + case fetchFromDefaults @[a] key config of + Just defaults -> + foldl' (\c (index, value) -> + c & addDefault (key /. "defaults" /. mkKey (show index)) value) config + $ zip [0 :: Integer ..] defaults + Nothing -> config + forM subkeys $ \k -> do + fetchFromConfig @a (key /. k) + (if isKeyPrefixOf (key /. "defaults") (key /. k) + then + configWithDefaults + else + configWithDefaults & addKeyMappings [(key /. k, key /. "prototype")]) + where + getSubkeysForItems :: IO (Maybe [Key]) + getSubkeysForItems = do + fetchFromConfig @(Maybe Text) (key /. "keys") config + >>= \case + Just rawKeys -> do + return $ + Just $ + nub $ + filter (/= "") $ + mkKey . + Text.unpack <$> + Text.split (== ',') rawKeys + Nothing -> do + subelements <- + sort + . nub + . filter (not . (`elem` ["prototype", "keys", "defaults"])) + . mapMaybe (\k -> case rawKeyComponents <$> stripKeyPrefix key k of + Just (subkey:_) -> Just $ fromText subkey + _ -> Nothing) + <$> listSubkeys key config + return $ if null subelements then Nothing else Just subelements + +instance FromConfig Int where + fromConfig = fetchFromConfigByRead + +instance FromConfig Integer where + fromConfig = fetchFromConfigByRead + +instance FromConfig Float where + fromConfig = fetchFromConfigByRead + +instance FromConfig BS.ByteString where + fromConfig = fetchFromConfigWith (Just . Text.encodeUtf8) + +instance FromConfig LBS.ByteString where + fromConfig = fetchFromConfigWith (Just . LBS.fromStrict . Text.encodeUtf8) + +instance forall a. (Typeable a, FromConfig a) => FromConfig (Maybe a) where + fromConfig key config = do + let + configWithUnwrappedDefault = + case fetchFromDefaults @(Maybe a) key config of + Just (Just defaultThing) -> do + config & addDefault key defaultThing + _ -> do + config + (Just <$> fetchFromConfig @a key configWithUnwrappedDefault) + `catch` (\(_e :: MissingRequiredKey) -> return Nothing) + +instance FromConfig Text where + fromConfig = fetchFromConfigWith Just + +instance FromConfig Bool where + fromConfig = fetchFromConfigWith parseBool + +-- | A newtype wrapper for a 'FilePath' to allow implementing 'FromConfig' +-- with something better than just a 'String' +newtype File = + File FilePath + deriving (Show, Eq, Ord, Read) + +unFile :: File -> FilePath +unFile (File f) = f + +instance IsString File where + fromString s = File s + +instance FromConfig File where + fromConfig key config = do + let defaultPath = fetchFromDefaults @File key config + + filepath <- fetchFromConfig @(Maybe String) key config + + extension <- fetchFromConfig @(Maybe String) (key /. "extension") config + dirname <- fetchFromConfig @(Maybe String) (key /. "dirname") config + basename <- fetchFromConfig @(Maybe String) (key /. "basename") config + filename <- fetchFromConfig @(Maybe String) (key /. "filename") config + + let + constructedFilePath = + applyIfPresent FilePath.replaceDirectory dirname + $ applyIfPresent FilePath.replaceBaseName basename + $ applyIfPresent FilePath.replaceExtension extension + $ applyIfPresent FilePath.replaceFileName filename + $ fromMaybe (unFile $ fromMaybe "" defaultPath) filepath + if FilePath.isValid constructedFilePath + then return $ File constructedFilePath + else throwMissingRequiredKeys @String + [ key + , key /. "extension" + , key /. "dirname" + , key /. "basename" + , key /. "filename" + ] + where + applyIfPresent f maybeComponent = + (\fp -> maybe fp (f fp) maybeComponent) + +-- | Helper function to parse a 'Bool' from 'Text' +parseBool :: Text -> Maybe Bool +parseBool text = + case Text.toLower text of + "false" -> Just False + "true" -> Just True + _ -> Nothing + +data OverrideFromConfig a = + OverrideFromConfig (Key -> Config -> IO a) + +-- | Allow the programmer to override this 'FromConfig' instance by providing +-- a special 'OverrideFromConfig' value. +-- +-- To avoid infinite recursion we remove the Override before calling the value + +-- | Helper function to implement fetchFromConfig using the 'Read' instance +fetchFromConfigByRead :: (Typeable a, Read a) => Key -> Config -> IO a +fetchFromConfigByRead = fetchFromConfigWith (readMaybe . Text.unpack) + +-- | Helper function to implement fetchFromConfig using the 'IsString' instance +fetchFromConfigByIsString :: (Typeable a, IsString a) => Key -> Config -> IO a +fetchFromConfigByIsString = fetchFromConfigWith (Just . fromString . Text.unpack) + +-- | Helper function to implement fetchFromConfig using some parsing function +fetchFromConfigWith :: forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a +fetchFromConfigWith parseValue key config = do + getKey key config >>= + \case + MissingKey k -> do + throwMissingRequiredKeys @a k + + FoundInSources k value -> + case parseValue value of + Just a -> do + return a + Nothing -> do + throwConfigParsingError @a k value + + FoundInDefaults k dynamics -> + case fromDynamics dynamics of + Just a -> do + return a + Nothing -> do + throwMissingRequiredKeys @a [k] + +fromDynamics :: forall a. Typeable a => [Dynamic] -> Maybe a +fromDynamics = + msum . fmap (fromDynamic @a) + +-- | Helper function does the plumbing of desconstructing a default into smaller +-- defaults, which is usefull for nested 'fetchFromConfig'. +addDefaultsAfterDeconstructingToDefaults + :: forall a. + Typeable a => + -- | Function to deconstruct the value + (a -> [(Key, Dynamic)]) -> + -- | Key where to look for the value + Key -> + -- | The config + Config -> + IO Config +addDefaultsAfterDeconstructingToDefaults destructureValue key config = do + case fetchFromDefaults @a key config of + Just value -> do + let newDefaults = + ((\(k, d) -> (key /. k, d)) <$> destructureValue value) + return $ + addDefaults newDefaults config + Nothing -> do + return config + +-- | Helper function to override the fetching function for a certain key. +-- +-- This function creates a 'Dynamic' that when added to the defaults allows +-- overriding the default 'FromConfig' instance. +overrideFetch :: forall a. Typeable a => (Key -> Config -> IO a) -> Dynamic +overrideFetch f = + toDyn @(OverrideFromConfig a) $ OverrideFromConfig f + +-- | Exception to show that a value couldn't be parsed properly +data ConfigParsingError = + ConfigParsingError Key Text TypeRep + deriving (Typeable, Eq) + +instance Exception ConfigParsingError +instance Show ConfigParsingError where + show (ConfigParsingError key value aTypeRep) = + concat + [ "Couldn't parse value '" + , Text.unpack value + , "' from key '" + , show key + , "' as " + , show aTypeRep + ] + +-- | Helper function to throw 'ConfigParsingError' +throwConfigParsingError :: forall a b. (Typeable a) => Key -> Text -> IO b +throwConfigParsingError key text = + throwIO $ configParsingError @a key text + +-- | Helper function to create a 'ConfigParsingError' +configParsingError :: forall a. (Typeable a) => Key -> Text -> ConfigParsingError +configParsingError key text = + ConfigParsingError key text $ typeRep (Proxy :: Proxy a) + +-- | Exception to show that some non optional 'Key' was missing while trying +-- to 'fetchFromConfig' +data MissingRequiredKey = + MissingRequiredKey [Key] TypeRep + deriving (Typeable, Eq) + +instance Exception MissingRequiredKey +instance Show MissingRequiredKey where + show (MissingRequiredKey keys aTypeRep) = + concat + [ "Failed to get a '" + , show aTypeRep + , "' from keys: " + , Text.unpack + $ Text.intercalate ", " + $ fmap (Text.pack . show) + $ keys + + ] + +-- | Simplified helper function to throw a 'MissingRequiredKey' +throwMissingRequiredKey :: forall t a. Typeable t => Key -> IO a +throwMissingRequiredKey key = + throwMissingRequiredKeys @t [key] + +-- | Simplified helper function to create a 'MissingRequiredKey' +missingRequiredKey :: forall t. Typeable t => Key -> MissingRequiredKey +missingRequiredKey key = + missingRequiredKeys @t [key] + +-- | Helper function to throw a 'MissingRequiredKey' +throwMissingRequiredKeys :: forall t a. Typeable t => [Key] -> IO a +throwMissingRequiredKeys keys = + throwIO $ missingRequiredKeys @t keys + +-- | Helper function to create a 'MissingRequiredKey' +missingRequiredKeys :: forall a. (Typeable a) => [Key] -> MissingRequiredKey +missingRequiredKeys keys = + MissingRequiredKey keys (typeRep (Proxy :: Proxy a)) + +-- | Fetch from value from the defaults map of a 'Config' or else throw +fetchRequiredFromDefaults :: forall a. (Typeable a) => Key -> Config -> IO a +fetchRequiredFromDefaults key config = + case fetchFromDefaults key config of + Nothing -> do + throwMissingRequiredKey @a key + Just a -> + return a + +-- | Fetch from value from the defaults map of a 'Config' or else return a 'Nothing' +fetchFromDefaults :: forall a. (Typeable a) => Key -> Config -> Maybe a +fetchFromDefaults key config = + getKeyFromDefaults key config + >>= fromDynamics @a + +-- | Same as 'fetchFromConfig' using the root key +fetchFromRootConfig :: forall a. (FromConfig a, Typeable a) => Config -> IO a +fetchFromRootConfig = + fetchFromConfig "" + +-- | Same as 'fetchFromConfig' but adding a user defined default before 'fetchFromConfig'ing +-- so it doesn't throw a MissingKeyError +fetchFromConfigWithDefault :: forall a. (Typeable a, FromConfig a) => Config -> Key -> a -> IO a +fetchFromConfigWithDefault config key configDefault = + fetchFromConfig key (config & addDefault key configDefault) + +-- | Same as 'fetchFromConfigWithDefault' using the root key +fetchFromRootConfigWithDefault :: forall a. (Typeable a, FromConfig a) => Config -> a -> IO a +fetchFromRootConfigWithDefault config configDefault = + fetchFromRootConfig (config & addDefault "" configDefault) + +-- | Purely 'Generic's machinery, ignore... +class FromConfigG f where + fromConfigG :: Key -> Config -> IO (f a) + +instance FromConfigG inner => + FromConfigG (D1 metadata inner) where + fromConfigG key config = do + M1 <$> fromConfigG key config + +instance (FromConfigWithConNameG inner, Constructor constructor) => + FromConfigG (C1 constructor inner) where + fromConfigG key config = + M1 <$> fromConfigWithConNameG @inner (conName @constructor undefined) key config + +-- | Purely 'Generic's machinery, ignore... +class FromConfigWithConNameG f where + fromConfigWithConNameG :: String -> Key -> Config -> IO (f a) + +instance (FromConfigWithConNameG left, FromConfigWithConNameG right) => + FromConfigWithConNameG (left :*: right) where + fromConfigWithConNameG s key config = do + leftValue <- fromConfigWithConNameG @left s key config + rightValue <- fromConfigWithConNameG @right s key config + return (leftValue :*: rightValue) + +instance (FromConfigG inner, Selector selector) => + FromConfigWithConNameG (S1 selector inner) where + fromConfigWithConNameG 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 Char.toLower $ Text.pack s + scopedKey = + case Text.stripPrefix prefix fieldName of + Just stripped -> applyFirst Char.toLower stripped + Nothing -> fieldName + in M1 <$> fromConfigG @inner (key /. fromText scopedKey) config + +instance (FromConfig inner, Typeable inner) => FromConfigG (Rec0 inner) where + fromConfigG key config = do + K1 <$> fetchFromConfig @inner key config + +-- | Purely 'Generic's machinery, ignore... +class IntoDefaultsG f where + intoDefaultsG :: Key -> f a -> [(Key, Dynamic)] + +instance IntoDefaultsG inner => + IntoDefaultsG (D1 metadata inner) where + intoDefaultsG key (M1 inner) = + intoDefaultsG key inner + +instance (IntoDefaultsWithConNameG inner, Constructor constructor) => + IntoDefaultsG (C1 constructor inner) where + intoDefaultsG key (M1 inner) = + intoDefaultsWithConNameG @inner (conName @constructor undefined) key inner + +-- | Purely 'Generic's machinery, ignore... +class IntoDefaultsWithConNameG f where + intoDefaultsWithConNameG :: String -> Key -> f a -> [(Key, Dynamic)] + +instance (IntoDefaultsWithConNameG left, IntoDefaultsWithConNameG right) => + IntoDefaultsWithConNameG (left :*: right) where + intoDefaultsWithConNameG s key (left :*: right) = do + intoDefaultsWithConNameG @left s key left + ++ + intoDefaultsWithConNameG @right s key right + +instance (IntoDefaultsG inner, Selector selector) => + IntoDefaultsWithConNameG (S1 selector inner) where + intoDefaultsWithConNameG s key (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 Char.toLower $ Text.pack s + scopedKey = + case Text.stripPrefix prefix fieldName of + Just stripped -> applyFirst Char.toLower stripped + Nothing -> fieldName + in intoDefaultsG @inner (key /. fromText scopedKey) inner + +instance (Typeable inner) => IntoDefaultsG (Rec0 inner) where + intoDefaultsG key (K1 inner) = do + [(key, toDyn inner)] diff --git a/src/Conferer/Key.hs b/src/Conferer/Key.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Key.hs @@ -0,0 +1,25 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Public API for Key related features +module Conferer.Key + ( Key + -- * Creating 'Key's + , mkKey + , fromText + -- * Maniputaing 'Key's + , (/.) + , stripKeyPrefix + , isKeyPrefixOf + , isValidKeyFragment + , isKeyCharacter + -- * Introspecting 'Key's + , rawKeyComponents + , unconsKey + ) where + +import Conferer.Key.Internal diff --git a/src/Conferer/Key/Internal.hs b/src/Conferer/Key/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Key/Internal.hs @@ -0,0 +1,103 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: unstable +-- Portability: portable +-- +-- Internal module for Key related features +module Conferer.Key.Internal where + +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Function (on) +import Data.List (stripPrefix, isPrefixOf) +import qualified Data.Char as Char +-- | This type is used extensivelly as a way to point into a 'Conferer.Source.Source' +-- and in turn into a 'Conferer.Config.Config'. The intended way to create them is +-- is using 'mkKey'. +-- +-- It's a list of alphanumeric words and each 'Conferer.Source.Source' can interpret +-- it as it sees fit. +newtype Key = Key + { unKey :: [Text] + } deriving (Eq, Ord) + +instance Show Key where + show key = "\"" ++ Text.unpack (keyName key) ++ "\"" + +instance IsString Key where + fromString = mkKey + +-- | Helper function to create 'Key's, this function always works, but +-- since 'Key's reject some string this function transforms the input +-- to provide lawful 'Key's instead of throwing. +-- +-- For example: +-- +-- > 'mkKey' "sOmE.KEy" == "some.key" +-- > 'mkKey' "1.key" == "1.key" +-- > 'mkKey' "1_thing.key" == "1thing.key" +-- > 'mkKey' "some....key" == "some.key" +-- > 'mkKey' ".." == "" +mkKey :: String -> Key +mkKey s = + Key . + filter (/= mempty) . + fmap (Text.filter isKeyCharacter . Text.toLower) . + Text.split (== '.') . + fromString + $ s + +-- | Same as 'mkKey' but for 'Text' +fromText :: Text -> Key +fromText = mkKey . Text.unpack + +-- | Collapse a key into a textual representation +keyName :: Key -> Text +keyName = Text.intercalate "." . unKey + +-- | This function tells if a key is a subkey of another key based +-- using key fragments instead of letters as units +-- +-- > 'isKeyPrefixOf' "foo" "foo.bar" == True +-- > 'isKeyPrefixOf' "foo" "foo" == True +-- > 'isKeyPrefixOf' "foo" "fooa" == False +isKeyPrefixOf :: Key -> Key -> Bool +isKeyPrefixOf = isPrefixOf `on` unKey + +-- | Given k1 and k2 this function drops k1 as a prefix from k2, if +-- k1 is not a prefix of k2 it returns 'Nothing' +-- +-- > 'keyPrefixOf' "foo" "foo.bar" == Just "bar" +-- > 'keyPrefixOf' "foo" "foo" == Just "" +-- > 'keyPrefixOf' "foo" "fooa" == Nothing +-- > 'keyPrefixOf' "" k == Just k +stripKeyPrefix :: Key -> Key -> Maybe Key +stripKeyPrefix key1 key2 = Key <$> (stripPrefix `on` unKey) key1 key2 + +-- | Concatenate two keys +(/.) :: Key -> Key -> Key +parent /. child = Key (unKey parent ++ unKey child) + +-- | Get raw components from a key, usually to do some manipulation +rawKeyComponents :: Key -> [Text] +rawKeyComponents = unKey + +-- | Get first component of a key and the rest of the key +unconsKey :: Key -> Maybe (Text, Key) +unconsKey (Key []) = Nothing +unconsKey (Key (k:ks)) = Just (k, Key ks) + +-- | Check if a 'Text' is a valid fragment of a 'Key', meaning +-- that each character 'isKeyCharacter' +isValidKeyFragment :: Text -> Bool +isValidKeyFragment t = + (not $ Text.null t) && Text.all isKeyCharacter t + +-- | Checks if the given 'Char' is a valid for a 'Key'. +-- Meaning it is a lower case ascii letter or a number. +isKeyCharacter :: Char -> Bool +isKeyCharacter c = + Char.isAsciiLower c || Char.isDigit c diff --git a/src/Conferer/Source.hs b/src/Conferer/Source.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Source.hs @@ -0,0 +1,18 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Public API module for Source related features +module Conferer.Source + ( Source(..) + , IsSource(..) + , SourceCreator + , module Conferer.Key + ) where + +import Conferer.Key +import Conferer.Config.Internal.Types +import Conferer.Source.Internal diff --git a/src/Conferer/Source/CLIArgs.hs b/src/Conferer/Source/CLIArgs.hs --- a/src/Conferer/Source/CLIArgs.hs +++ b/src/Conferer/Source/CLIArgs.hs @@ -1,43 +1,76 @@ -module Conferer.Source.CLIArgs - ( - -- * Command line arguments Source - -- | This source provides keys from the command line arguments passed into - -- the program. It only accepts arguments with @--@ and an equals, for - -- example: @./awesomeapp --warp.port=5000@ - mkCLIArgsSource - , mkCLIArgsSource' - , parseArgsIntoKeyValue - ) -where +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Command line arguments based source +module Conferer.Source.CLIArgs where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as Text -import Data.Maybe (mapMaybe) -import Data.String (fromString) -import System.Environment (getArgs) +import Data.Maybe (mapMaybe) +import System.Environment (getArgs) -import Conferer.Types -import Conferer.Source.Simple +import Conferer.Source +import qualified Conferer.Source.InMemory as InMemory --- | Create a 'SourceCreator' for CLIArgs from a argument list -mkCLIArgsSource' :: [String] -> SourceCreator -mkCLIArgsSource' args = \config -> do - let configMap = parseArgsIntoKeyValue args - mkMapSource configMap config +-- | This source provides keys from the command line arguments passed into +-- the program. It only accepts arguments with @--@ and an equals, for +-- example: @./awesomeapp --warp.port=5000@ +data CLIArgsSource = + CLIArgsSource + { originalCliArgs :: RawCLIArgs + , innerSource :: Source + } deriving (Show) --- | Same as 'mkCLIArgsSource'' but using 'getArgs' to provide the argument --- list -mkCLIArgsSource :: SourceCreator -mkCLIArgsSource = \config -> do +-- | Type alias for cli args +type RawCLIArgs = [String] + +instance IsSource CLIArgsSource where + getKeyInSource CLIArgsSource{..} key = do + getKeyInSource innerSource key + getSubkeysInSource CLIArgsSource{..} key = do + getSubkeysInSource innerSource key + + +-- | Create a 'SourceCreator' using 'fromEnv' +fromConfig :: SourceCreator +fromConfig = \_config -> + fromEnv + +-- | Create a 'Source' using 'fromArgs' but using real cli args +fromEnv :: IO Source +fromEnv = do args <- getArgs - mkCLIArgsSource' args config + return $ fromArgs args +-- | Create a 'Source' using cli args passed as parameter +fromArgs :: RawCLIArgs -> Source +fromArgs originalCliArgs = + let configMap = parseArgsIntoKeyValue originalCliArgs + innerSource = InMemory.fromAssociations configMap + in Source $ CLIArgsSource {..} + -- | Parse an argument list into a dictionary suitable for a 'Source' parseArgsIntoKeyValue :: [String] -> [(Key, Text)] parseArgsIntoKeyValue = - fmap (\(k, s) -> (fromString $ Text.unpack k, s)) . - fmap (\s -> fmap (Text.drop 1) $ Text.breakOn "=" s). + fmap (\s -> + let (k, rawValue) = Text.breakOn "=" s + in case Text.uncons rawValue of + Nothing -> (fromText k, "true") + (Just ('=', v)) -> (fromText k, v) + -- Since rawValue comes from breaking on "=" the first character + -- should always be '=' or none at all + (Just (_, _)) -> + error $ unlines + [ "'" + , Text.unpack rawValue + , "' should always start with '='" + ] + ) . mapMaybe (Text.stripPrefix "--") . takeWhile (/= "--") . fmap Text.pack diff --git a/src/Conferer/Source/Env.hs b/src/Conferer/Source/Env.hs --- a/src/Conferer/Source/Env.hs +++ b/src/Conferer/Source/Env.hs @@ -1,67 +1,84 @@ -module Conferer.Source.Env - ( --- * Env Source --- | This 'Source' provides config values from env vars given a prefix that's --- used to avoid colliding with different system configuration --- --- For example if you use the 'Prefix' "awesomeapp" and get the 'Key' --- "warp.port" this source will try to lookup the env var called --- @AWESOMEAPP_WARP_PORT@. - --- * Usage --- | To use this source simply choose a prefix and add it using the --- 'addSource' function like: +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable -- --- @ --- config & 'addSource' ('mkEnvSource' "awesomeapp") --- @ - mkEnvSource - , mkEnvSource' - , Prefix - , LookupEnvFunc - , keyToEnvVar - ) where - +-- Environment based source +{-# LANGUAGE RecordWildCards #-} +module Conferer.Source.Env where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as Text import qualified System.Environment as System +import Data.Maybe (mapMaybe) -import Conferer.Types +import Conferer.Source +import qualified Conferer.Source.InMemory as InMemory --- | 'SourceCreator' for env 'Source' that uses the real 'System.lookupEnv' --- function -mkEnvSource :: Prefix -> SourceCreator -mkEnvSource prefix = - mkEnvSource' System.lookupEnv prefix +-- | Source that interfaces with the environment transforming keys +-- by uppercasing and interspersing underscores, and using a prefix +-- to avoid clashing with system env vars +-- +-- so with "app" prefix, @"some.key"@ turns into @APP_SOME_KEY@ +data EnvSource = + EnvSource + { environment :: RawEnvironment + , keyPrefix :: Prefix + , innerSource :: Source + } deriving (Show) --- | 'SourceCreator' for env 'Source' that allows parameterizing the --- function used to lookup for testing -mkEnvSource' :: LookupEnvFunc -> Prefix -> SourceCreator -mkEnvSource' lookupEnv prefix = \_config -> - return $ - Source - { getKeyInSource = \k -> do - let envVarName = Text.unpack $ keyToEnvVar prefix k - fmap Text.pack <$> lookupEnv envVarName - } +-- | Type alias for the environment +type RawEnvironment = [(String, String)] --- | Type alias for the function to lookup env vars -type LookupEnvFunc = String -> IO (Maybe String) +-- | Type alias for the env vars prefix +type Prefix = Text +instance IsSource EnvSource where + getKeyInSource EnvSource{..} key = do + getKeyInSource innerSource key + getSubkeysInSource EnvSource{..} key = do + getSubkeysInSource innerSource key --- | A text to namespace env vars -type Prefix = Text +-- | Create a 'SourceCreator' using 'fromEnv' +fromConfig :: Prefix -> SourceCreator +fromConfig prefix _config = do + fromEnv prefix +-- | Create a 'Source' using the real environment +fromEnv :: Prefix -> IO Source +fromEnv prefix = do + rawEnvironment <- System.getEnvironment + return $ fromEnvList rawEnvironment prefix + +-- | Create a 'Source' using a hardcoded list of env vars +fromEnvList :: RawEnvironment -> Prefix -> Source +fromEnvList environment keyPrefix = + let + mappings = + mapMaybe (\(key, v) -> do + k <- envVarToKey keyPrefix $ Text.pack key + return (k, Text.pack v) + ) + environment + innerSource = InMemory.fromAssociations mappings + in Source EnvSource {..} + -- | Get the env name from a prefix and a key by uppercasing and -- intercalating underscores --- --- >>> keyToEnVar "awesomeapp" "warp.port" --- "AWESOMEAPP_WARP_PORT" keyToEnvVar :: Prefix -> Key -> Text -keyToEnvVar prefix (Path keys) = +keyToEnvVar prefix keys = Text.toUpper $ Text.intercalate "_" $ filter (/= mempty) - $ prefix : keys + $ prefix : rawKeyComponents keys + +-- | The opossite of 'keyToEnvVar' +envVarToKey :: Prefix -> Text -> Maybe Key +envVarToKey prefix envVar = + let + splitEnvVar = fromText $ Text.replace "_" "." envVar + in + stripKeyPrefix (fromText prefix) splitEnvVar diff --git a/src/Conferer/Source/Files.hs b/src/Conferer/Source/Files.hs --- a/src/Conferer/Source/Files.hs +++ b/src/Conferer/Source/Files.hs @@ -1,21 +1,25 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Public API module providing some helper functions related to files +{-# LANGUAGE TypeApplications #-} module Conferer.Source.Files where -import qualified Data.Text as Text -import Data.Maybe (fromMaybe) - -import Conferer.Types -import Conferer.FromConfig.Basics () +import Data.Maybe (fromMaybe) +import System.FilePath -fromRight :: a -> Either e a -> a -fromRight a (Left _) = a -fromRight _ (Right a) = a +import Conferer.Config +import Conferer.FromConfig -getFilePathFromEnv :: Config -> String -> IO FilePath -getFilePathFromEnv config extension = do - env <- updateFromConfig "env" config "development" - return $ mconcat - [ "config/" - , Text.unpack env - , "." - , extension - ] +-- | Helper function to get a file from the config specifying the extension and using +-- current env +getFilePathFromEnv :: Key -> String -> Config -> IO FilePath +getFilePathFromEnv key extension config = do + env <- fromMaybe "development" <$> fetchFromConfig @(Maybe String) "env" config + let defaultPath = "config" env <.> extension + File filepath <- fetchFromConfigWithDefault @File config key $ File defaultPath + return filepath diff --git a/src/Conferer/Source/InMemory.hs b/src/Conferer/Source/InMemory.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Source/InMemory.hs @@ -0,0 +1,44 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- In memory source mostly used for testing +{-# LANGUAGE RecordWildCards #-} +module Conferer.Source.InMemory where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) + +import Conferer.Source + +-- | A 'Source' mostly use for mocking which is configured directly using a +-- 'Map' +newtype InMemorySource = + InMemorySource + { configMap :: Map Key Text + } deriving (Show, Eq) + +instance IsSource InMemorySource where + getKeyInSource InMemorySource {..} key = + return $ Map.lookup key configMap + getSubkeysInSource InMemorySource {..} key = do + return $ filter (\k -> key `isKeyPrefixOf` k && key /= k) $ Map.keys configMap + +-- | Create a 'SourceCreator' from a list of associations +fromConfig :: [(Key, Text)] -> SourceCreator +fromConfig configMap _config = + return $ fromAssociations configMap + +-- | Create a 'Source' from a 'Map' +fromMap :: Map Key Text -> Source +fromMap configMap = + Source . InMemorySource $ configMap + +-- | Create a 'Source' from a list of associations +fromAssociations :: [(Key, Text)] -> Source +fromAssociations = + fromMap . Map.fromList diff --git a/src/Conferer/Source/Internal.hs b/src/Conferer/Source/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Source/Internal.hs @@ -0,0 +1,35 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: unstable +-- Portability: portable +-- +-- Internal module for Key related features +{-# LANGUAGE ExistentialQuantification #-} +module Conferer.Source.Internal where + +import Data.Text (Text) +import Conferer.Key (Key) + +-- | Concrete type for 'IsSource' +data Source = forall s. (IsSource s, Show s) => Source s + +instance Show Source where + show (Source s) = "Source " ++ show s + +-- | Main interface for interacting with external systems that provide configuration +-- which will be used by 'Conferer.FromConfig.FromConfig' to fetch values. +class IsSource s where + -- | This function is used by the 'Conferer.Config.Config' to get values from this + -- 'Source'. + getKeyInSource :: s -> Key -> IO (Maybe Text) + -- | This function is used by the 'Conferer.Config.Config' to list possible values + -- from the 'Source' that if the user 'getKeyInSource', it will be found. + getSubkeysInSource :: s -> Key -> IO [Key] + +instance IsSource Source where + getKeyInSource (Source source) = + getKeyInSource source + getSubkeysInSource (Source source) = + getSubkeysInSource source diff --git a/src/Conferer/Source/Mapping.hs b/src/Conferer/Source/Mapping.hs deleted file mode 100644 --- a/src/Conferer/Source/Mapping.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Conferer.Source.Mapping - ( - -- * Namespaced higher-order source - -- | This source takes a source and returns a new source that - -- always transforms the key according to either a function for - -- 'mkMappingSource'' or a 'Map' for 'mkMappingSource' - mkMappingSource - , mkMappingSource' - ) -where - -import Data.Map (Map) -import qualified Data.Map as Map - -import Conferer.Types - --- | Create a 'SourceCreator' using a function to transform the supplied keys --- and another 'SourceCreator' -mkMappingSource' :: (Key -> Maybe Key) -> SourceCreator -> SourceCreator -mkMappingSource' mapper sourceCreator config = do - configSource <- sourceCreator config - - return $ Source - { getKeyInSource = \k -> do - case mapper k of - Just newKey -> getKeyInSource configSource newKey - Nothing -> return Nothing - } - --- | Create a 'SourceCreator' using a 'Map' 'Key' 'Key' to transform the supplied keys --- and another 'SourceCreator' -mkMappingSource :: Map Key Key -> SourceCreator -> SourceCreator -mkMappingSource configMap configSource = - mkMappingSource' (`Map.lookup` configMap) configSource diff --git a/src/Conferer/Source/Namespaced.hs b/src/Conferer/Source/Namespaced.hs --- a/src/Conferer/Source/Namespaced.hs +++ b/src/Conferer/Source/Namespaced.hs @@ -1,23 +1,43 @@ -module Conferer.Source.Namespaced - ( - -- * Namespaced higher-order source - -- | This source takes a source and returns a new source that - -- always checks that the 'Key' given always starts with certain 'Key' - -- and then strips that prefix before consulting its inner Source - mkNamespacedSource - ) where +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Source that namespaces an inner source +{-# LANGUAGE RecordWildCards #-} +module Conferer.Source.Namespaced where -import Data.List (stripPrefix) +import Conferer.Source -import Conferer.Types +-- | This source takes a source and returns a new source that +-- always checks that the 'Key' given always starts with certain 'Key' +-- and then strips that prefix before consulting its inner Source +data NamespacedSource = + NamespacedSource + { scopeKey :: Key + , innerSource :: Source + } deriving (Show) +instance IsSource NamespacedSource where + getKeyInSource NamespacedSource{..} key = do + case stripKeyPrefix scopeKey key of + Just innerKey -> getKeyInSource innerSource innerKey + Nothing -> return Nothing + getSubkeysInSource NamespacedSource{..} key = do + case stripKeyPrefix scopeKey key of + Just innerKey -> do + fmap (scopeKey /.) <$> getSubkeysInSource innerSource innerKey + Nothing -> return [] + -- | Create a 'SourceCreator' from a prefix and another 'SourceCreator' -mkNamespacedSource :: Key -> SourceCreator -> SourceCreator -mkNamespacedSource (Path key) configCreator = \config -> do - configSource <- configCreator config - return $ Source - { getKeyInSource = \(Path k) -> do - case stripPrefix key k of - Just newKey -> getKeyInSource configSource (Path newKey) - Nothing -> return Nothing - } +fromConfig :: Key -> SourceCreator -> SourceCreator +fromConfig scopeKey configCreator = \config -> do + innerSource <- configCreator config + return $ fromInner scopeKey innerSource + +-- | Create a 'Source' from a prefix and another 'Source' +fromInner :: Key -> Source -> Source +fromInner scopeKey innerSource = do + Source $ NamespacedSource{..} diff --git a/src/Conferer/Source/Null.hs b/src/Conferer/Source/Null.hs --- a/src/Conferer/Source/Null.hs +++ b/src/Conferer/Source/Null.hs @@ -1,18 +1,32 @@ -module Conferer.Source.Null - ( - -- * Does Nothing Source - -- | The stub source that never has a key - mkNullSource - ) -where +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Do nothing source +module Conferer.Source.Null where -import Conferer.Types +import Conferer.Source --- | Create a null 'Source' -mkNullSource :: SourceCreator -mkNullSource _config = - return $ Source - { getKeyInSource = - \_k -> do - return Nothing - } +-- | Stub source that has no keys +data NullSource = + NullSource + deriving (Show, Eq) + +instance IsSource NullSource where + getKeyInSource _source _key = + return Nothing + getSubkeysInSource _source _key = + return [] + +-- | Create 'SourceCreator' +fromConfig :: SourceCreator +fromConfig _config = + return empty + +-- | Create a 'Source' +empty :: Source +empty = + Source $ NullSource diff --git a/src/Conferer/Source/PropertiesFile.hs b/src/Conferer/Source/PropertiesFile.hs --- a/src/Conferer/Source/PropertiesFile.hs +++ b/src/Conferer/Source/PropertiesFile.hs @@ -1,44 +1,74 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Properties file source module Conferer.Source.PropertiesFile where -import Data.Text (Text) -import Data.Function ((&)) -import System.Directory (doesFileExist) -import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Function ((&)) +import System.Directory (doesFileExist) +import Data.Maybe (catMaybes) import qualified Data.Text as Text import qualified Data.Text.IO as Text -import Conferer.Types -import Conferer.Source.Files -import Conferer.Source.Null -import Conferer.Source.Simple +import Conferer.Source +import Conferer.Source.Files +import qualified Conferer.Source.Null as Null +import qualified Conferer.Source.InMemory as InMemory --- | 'SourceCreator' for properties file 'Source' that read from a --- config file in @config/{env}.properties@ and parses it as a properties --- file with @some.key=a value@ lines -mkPropertiesFileSource :: SourceCreator -mkPropertiesFileSource = \config -> do - filePath <- getFilePathFromEnv config "properties" +-- | 'Source' that uses a config file in @config/{env}.properties@ and +-- parses it as a properties file with @some.key=a value@ lines +data PropertiesFileSource = + PropertiesFileSource + { originalFilePath :: FilePath + , innerSource :: Source + } deriving (Show) + +instance IsSource PropertiesFileSource where + getKeyInSource PropertiesFileSource{..} key = do + getKeyInSource innerSource key + getSubkeysInSource PropertiesFileSource{..} key = do + getSubkeysInSource innerSource key + +-- | Create a 'SourceCreator' using 'getFilePathFromEnv' to get the path to file +-- and 'fromFilePath' +fromConfig :: Key -> SourceCreator +fromConfig key config = do + filePath <- getFilePathFromEnv key "properties" config + fromFilePath' filePath + +-- | Create a 'SourceCreator' reading the file and using that as a properties file, but +-- if the file doesn't exist do nothing. +fromFilePath :: FilePath -> SourceCreator +fromFilePath filepath _config = + fromFilePath' filepath + +-- | Create a 'Source' reading the file and using that as a properties file, but +-- if the file doesn't exist do nothing. +fromFilePath' :: FilePath -> IO Source +fromFilePath' filePath = do fileExists <- doesFileExist filePath if fileExists then do fileContent <- Text.readFile filePath - mkPropertiesFileSource' fileContent config - else do - mkNullSource config - - --- | 'SourceCreator' for properties file 'Source' that only parses a --- given 'Text' as a properties file -mkPropertiesFileSource' :: Text -> SourceCreator -mkPropertiesFileSource' fileContent = - \config -> do - let keyValues = - fileContent - & Text.lines - & fmap lineToKeyValue - & catMaybes - mkMapSource keyValues config + return $ fromFileContent filePath fileContent + else + return Null.empty +-- | Create a 'Source' using some content as a properties file +fromFileContent :: FilePath -> Text -> Source +fromFileContent originalFilePath fileContent = + let keyValues = + fileContent + & Text.lines + & fmap lineToKeyValue + & catMaybes + innerSource = InMemory.fromAssociations keyValues + in Source $ PropertiesFileSource {..} -- | Transform a line into a key/value pair (or not) lineToKeyValue :: Text -> Maybe (Key, Text) @@ -47,7 +77,7 @@ & (\(rawKey, rawValue) -> case Text.stripPrefix "=" rawValue of Just value -> - Just (Path $ Text.splitOn "." rawKey, value) + Just (fromText rawKey, value) Nothing -> Nothing ) diff --git a/src/Conferer/Source/Simple.hs b/src/Conferer/Source/Simple.hs deleted file mode 100644 --- a/src/Conferer/Source/Simple.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Conferer.Source.Simple - ( - -- * Simple Source - -- | This source provides values from a hardcoded Map passed at creation - -- time that can not be changed afterwards, it's mostly used as a necessary - -- utility - mkMapSource - , mkMapSource' - , mkPureMapSource - ) where - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text (Text) - -import Conferer.Types - --- | Make a 'SourceCreator' from a 'Map' -mkMapSource' :: Map Key Text -> SourceCreator -mkMapSource' configMap _config = - return $ mkPureMapSource configMap - --- | Make a 'Source' from a 'Map' -mkPureMapSource :: Map Key Text -> Source -mkPureMapSource configMap = - Source - { getKeyInSource = - \k -> do - return $ Map.lookup k configMap - } - --- | Make a 'Source' from 'List' of 'Key', 'Text' pairs -mkMapSource :: [(Key, Text)] -> SourceCreator -mkMapSource = mkMapSource' . Map.fromList diff --git a/src/Conferer/Test.hs b/src/Conferer/Test.hs new file mode 100644 --- /dev/null +++ b/src/Conferer/Test.hs @@ -0,0 +1,24 @@ +-- | +-- Copyright: (c) 2019 Lucas David Traverso +-- License: MPL-2.0 +-- Maintainer: Lucas David Traverso +-- Stability: stable +-- Portability: portable +-- +-- Some testing utilities +module Conferer.Test + ( configWith + ) where + +import Conferer.Config +import qualified Conferer.Source.InMemory as InMemory +import Data.Text (Text) +import Data.Dynamic + +-- | Create a Config mostly used for testing 'Conferer.FromConfig.FromConfig' +-- instances without having to create a full config +configWith :: [(Key, Dynamic)] -> [(Key, Text)] -> IO Config +configWith defaults keyValues = + emptyConfig + & addDefaults defaults + & addSource (InMemory.fromConfig keyValues) diff --git a/src/Conferer/Types.hs b/src/Conferer/Types.hs deleted file mode 100644 --- a/src/Conferer/Types.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -module Conferer.Types where - -import Data.String -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Map (Map) -import qualified Data.Map as Map -import Control.Exception -import Data.Typeable -import GHC.Generics - --- | Core interface for library provided configuration, basically consists of --- getting a 'Key' and informing returning a maybe signaling the value and --- if it's present in that specific source -data Source = - Source - { getKeyInSource :: Key -> IO (Maybe Text) - } - --- | The way to index 'Source's, basically list of names that will be adapted --- to whatever the source needs -newtype Key - = Path { unKey :: [Text] } - deriving (Show, Eq, Ord) - -instance IsString Key where - fromString s = Path $ filter (/= mempty) $ Text.split (== '.') $ fromString s - --- | Collapse a key into a textual representation -keyName :: Key -> Text -keyName = Text.intercalate "." . unKey - --- | Core type that the user of this library interact with, in the future it may --- contain more this besides a list of sources -data Config = - Config - { sources :: [Source] - , defaults :: Map Key Text - } - --- | The type for creating a source given a 'Config', some sources require a --- certain configuration to be initialized (for example: the redis source --- needs connection info to connect to the server) -type SourceCreator = Config -> IO Source - -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 DefaultConfig a where - configDef :: a - --- | Main typeclass for defining the way to get values from config, hiding the --- 'Text' based nature of the 'Source'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 --- '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 FromConfig a where - updateFromConfig :: 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 FromConfigG f where - updateFromConfigG :: Key -> Config -> f a -> IO (f a) - fetchFromConfigG :: Key -> Config -> IO (Maybe (f a)) - -data ConfigParsingError = - ConfigParsingError Key Text TypeRep - deriving (Typeable, Eq) - -instance Show ConfigParsingError where - show (ConfigParsingError key value typeRep) = - concat - [ "Couldn't parse value '" - , Text.unpack value - , "' from key '" - , Text.unpack (keyName key) - , "' as " - , show typeRep - ] - -instance Exception ConfigParsingError - -data FailedToFetchError = - FailedToFetchError Key TypeRep - deriving (Typeable, Eq) - -instance Show FailedToFetchError where - show (FailedToFetchError key typeRep) = - concat - [ "Couldn't get a " - , show typeRep - , " from key '" - , Text.unpack (keyName key) - , "'" - ] - -instance Exception FailedToFetchError diff --git a/test/Conferer/ConfigSpec.hs b/test/Conferer/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/ConfigSpec.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE TypeApplications #-} +module Conferer.ConfigSpec where + +import Test.Hspec +import Data.Text (Text) +import Data.Dynamic + +import Conferer.Config +import Conferer.Source.InMemory +import Conferer.FromConfig.Internal (fromDynamics) + +missingKey :: Key -> KeyLookupResult -> Bool +missingKey expectedKey (MissingKey k) = [expectedKey] == k +missingKey _ _ = False + +foundInSources :: Key -> Text -> KeyLookupResult -> Bool +foundInSources expectedKey expected (FoundInSources k t) = + expected == t && expectedKey == k +foundInSources _keyExpected _expected _ = + False + +foundInDefaults :: forall expected. (Eq expected, Typeable expected) + => Key -> expected -> KeyLookupResult -> Bool +foundInDefaults expectedKey expected (FoundInDefaults k d) = + Just expected == fromDynamics @expected d && expectedKey == k +foundInDefaults _expctedKey _expected _ = + False + +spec :: Spec +spec = do + describe "Config" $ do + let mkConfig keyMappings defaults content = + pure (emptyConfig + & addKeyMappings keyMappings + & addDefaults defaults) + >>= addSource (fromConfig content) + describe "#getKey" $ do + it "getting a non existent key returns missing key" $ do + c <- mkConfig [] [] [] + res <- getKey "aaa" c + res `shouldSatisfy` missingKey "aaa" + + it "getting a key only present in the defaults" $ do + c <- mkConfig [] [("some.key", toDyn @Int 1)] [] + res <- getKey "some.key" c + res `shouldSatisfy` foundInDefaults "some.key" (1 :: Int) + + context "with multiple sources and defaults" $ do + let mkConfig' defaults sourceWithPriority otherSource = + pure (emptyConfig + & addDefaults defaults) + >>= addSource (fromConfig sourceWithPriority) + >>= addSource (fromConfig otherSource) + + it "getting an key returns unwraps the original map" $ do + c <- mkConfig' [] [] [("some.key", "1")] + res <- getKey "some.key" c + res `shouldSatisfy` foundInSources "some.key" "1" + + it "getting an existent key returns in the bottom maps gets it" $ do + c <- mkConfig' [] [("some.key", "2")] [("some.key", "1")] + res <- getKey "some.key" c + res `shouldSatisfy` foundInSources "some.key" "2" + describe "with some key mapping" $ do + context "with basic one to one mapping" $ + it "gets the value through a mapping" $ do + c <- mkConfig + [ ("something", "server") ] + [] + [ ("server", "aaa") ] + res <- getKey "something" c + res `shouldSatisfy` foundInSources "server" "aaa" + context "with a nested key mapping" $ do + it "goes through all the mappings and gets the right value" $ do + c <- mkConfig + [ ("something", "else") + , ("else", "server") + ] + [] + [ ("server", "aaa") + ] + res <- getKey "something" c + res `shouldSatisfy` foundInSources "server" "aaa" + context "with circular mappings" $ do + it "gets the first key" $ do + c <- mkConfig + [ ("a", "b") + , ("b", "a") + , ("b", "c") + ] + [] + [ ("c", "aaa") + ] + res <- getKey "a" c + res `shouldSatisfy` foundInSources "c" "aaa" + context "with nested key" $ do + it "maps the right upper key" $ do + c <- mkConfig + [ ("a", "b") + ] + [] + [ ("b.k", "aaa") + ] + res <- getKey "a.k" c + res `shouldSatisfy` foundInSources "b.k" "aaa" + context "with some defaults" $ do + it "maps and allows getting the default" $ do + c <- mkConfig + [ ("a", "b") + ] + [ ("b", toDyn False) + ] + [] + res <- getKey "a" c + res `shouldSatisfy` foundInDefaults "a" False + describe "#listSubkeys" $ do + it "return an empty list when nothing is configured" $ do + c <- mkConfig [] [] [] + res <- listSubkeys "some" c + res `shouldBe` [] + context "with some values in the config" $ do + it "when nothing is configured" $ do + c <- mkConfig [] [] [("some.key", "")] + res <- listSubkeys "some" c + res `shouldBe` ["some.key"] + context "with a config that has a value configured and \ + \we get that same value" $ do + it "returns that key in the list of subkeys" $ do + c <- mkConfig [] [] [("some", "")] + res <- listSubkeys "some" c + res `shouldBe` [] + context "with a config that has a value configured but \ + \we get a different value" $ do + it "returns an empty list" $ do + c <- mkConfig [] [] [("some", "")] + res <- listSubkeys "other" c + res `shouldBe` [] + context "with a config with defaults" $ do + it "returns those defaults in the list" $ do + c <- mkConfig [] [("some.key", toDyn @Int 7)] [] + res <- listSubkeys "some" c + res `shouldBe` ["some.key"] + context "with configs in both defaults and sources" $ do + it "returns both results combined" $ do + c <- mkConfig [] [("some.key", toDyn @Int 7)] [("some.other", "")] + res <- listSubkeys "some" c + res `shouldBe` ["some.key", "some.other"] + context "mappings" $ do + context "with a simple mapping and a configured value" $ do + it "returns the keys that are present based on the mapping" $ do + c <- mkConfig + [ ("a", "b") + ] + [] + [ ("b.k", "aaa") + ] + res <- listSubkeys "a" c + res `shouldBe` ["a.k"] + context "with a multiple mappings and a configured value" $ do + it "returns the right keys" $ do + c <- mkConfig + [ ("a", "b") + , ("b", "c") + ] + [] + [ ("c.k", "aaa") + ] + res <- listSubkeys "a" c + res `shouldBe` ["a.k"] + context "with circular mappings" $ do + it "returns the right keys" $ do + c <- mkConfig + [ ("a", "b") + , ("b", "a") + ] + [] + [ ("a.k", "aaa") + ] + res <- listSubkeys "a" c + res `shouldBe` ["a.k"] + context "with reducing mappings" $ do + xit "returns the right keys" $ do + c <- mkConfig + [ ("a.k", "a") + ] + [] + [ ("a.k", "aaa") + ] + res <- listSubkeys "a" c + -- getKey "a.k.k" c >>= print + res `shouldBe` ["a.k", "a.k.k"] + it "keys that are present based on the mapping" $ do + c <- mkConfig + [ ("a", "b") + ] + [ ("b.k", toDyn @String "aaa") + ] + [ ] + res <- listSubkeys "a" c + res `shouldBe` ["a.k"] + + describe "#addDefaults" $ do + context "with multiple defaults on the same key" $ do + it "the last one has more priority" $ do + let c = emptyConfig + & addDefaults + [ ("some.key", toDyn @Int 1) + , ("some.key", toDyn @Int 2) + ] + res <- getKey "some.key" c + res `shouldSatisfy` foundInDefaults "some.key" (2 :: Int) diff --git a/test/Conferer/FromConfig/BasicsSpec.hs b/test/Conferer/FromConfig/BasicsSpec.hs deleted file mode 100644 --- a/test/Conferer/FromConfig/BasicsSpec.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# 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 & addSource (mkMapSource 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/FromConfig/BoolSpec.hs b/test/Conferer/FromConfig/BoolSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/BoolSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Conferer.FromConfig.BoolSpec (spec) where + +import Test.Hspec +import Conferer.FromConfig.Extended + +spec :: Spec +spec = do + context "Basic fetching" $ do + describe "fetching a Bool from config" $ do + ensureEmptyConfigThrows @Bool + + ensureUsingDefaultReturnsSameValue @Bool True + ensureUsingDefaultReturnsSameValue @Bool False + + ensureSingleConfigParsesTheRightThing @Bool "true" True + ensureSingleConfigParsesTheRightThing @Bool "false" False + + context "parsing is case insensitive" $ do + ensureSingleConfigParsesTheRightThing @Bool "faLSe" False + ensureSingleConfigParsesTheRightThing @Bool "TRUE" True + + ensureSingleConfigThrowsParserError @Bool "nope" diff --git a/test/Conferer/FromConfig/Extended.hs b/test/Conferer/FromConfig/Extended.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/Extended.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Conferer.FromConfig.Extended + ( module Conferer.FromConfig + , module GHC.Generics + , configWith + , anyConfigParserError + , aConfigParserError + , aMissingRequiredKey + , aMissingRequiredKeys + , ensureEmptyConfigThrows + , ensureUsingDefaultReturnsSameValue + , ensureSingleConfigParsesTheRightThing + , ensureSingleConfigThrowsParserError + , ensureSingleConfigThrows + , ensureFetchParses + , ensureFetchThrows + , toDyn + , module Conferer.Config + ) where + +import Data.Text +import Data.Typeable +import Test.Hspec +import GHC.Generics +import Control.Exception +import Data.Dynamic +import Data.Function + +import Conferer.Config +import Conferer.FromConfig.Internal + ( MissingRequiredKey(..) + , ConfigParsingError(..) + ) +import Conferer.FromConfig +import qualified Conferer.Source.InMemory as InMemory + +configWith :: [(Key, Text)] -> IO Config +configWith keyValues = + emptyConfig + & addSource (InMemory.fromConfig keyValues) + +anyConfigParserError :: ConfigParsingError -> Bool +anyConfigParserError _ = True + +aConfigParserError :: Key -> Text -> ConfigParsingError -> Bool +aConfigParserError key txt (ConfigParsingError k t _) = + key == k && t == txt + +aMissingRequiredKey :: forall t. Typeable t => Key -> MissingRequiredKey -> Bool +aMissingRequiredKey key (MissingRequiredKey k t) = + [key] == k && typeRep (Proxy :: Proxy t) == t + +aMissingRequiredKeys :: forall t. Typeable t => [Key] -> MissingRequiredKey -> Bool +aMissingRequiredKeys keys (MissingRequiredKey k t) = + keys == k && typeRep (Proxy :: Proxy t) == t + +data InvalidThing = InvalidThing deriving (Show, Eq) + +ensureEmptyConfigThrows :: forall a. (Typeable a, FromConfig a) => SpecWith () +ensureEmptyConfigThrows = + context "with empty config" $ do + it "throws an exception" $ do + config <- configWith [] + fetchFromConfig @a "some.key" config + `shouldThrow` aMissingRequiredKey @a "some.key" + +ensureSingleConfigThrowsParserError :: + forall a. (FromConfig a, Typeable a) => + Text -> SpecWith () +ensureSingleConfigThrowsParserError keyContent = + context "with invalid types in the defaults" $ do + it "throws an exception" $ do + config <- configWith [("some.key", keyContent)] + fetchFromConfig @a "some.key" config + `shouldThrow` aConfigParserError "some.key" keyContent + +ensureUsingDefaultReturnsSameValue :: + forall a. (Typeable a, Eq a, Show a, FromConfig a) => + a -> SpecWith () +ensureUsingDefaultReturnsSameValue value = + context ("with a default of '" ++ show value ++ "'") $ do + it "gets that same value" $ do + config <- configWith [] + fetchedValue <- fetchFromConfig @a "some.key" + (config & addDefault "some.key" value) + fetchedValue `shouldBe` value + +ensureSingleConfigParsesTheRightThing :: + forall a. (Eq a, Show a, FromConfig a, Typeable a) => + Text -> a -> SpecWith () +ensureSingleConfigParsesTheRightThing keyContent value = + context ("with a config value of '" ++ unpack keyContent ++ "'" ) $ do + it "gets the right value" $ do + config <- configWith [("some.key", keyContent)] + fetchedValue <- fetchFromConfig @a "some.key" config + fetchedValue `shouldBe` value + +ensureSingleConfigThrows :: + forall a e. (FromConfig a, Typeable a, Exception e) => + Text -> (e -> Bool) -> SpecWith () +ensureSingleConfigThrows keyContent checkException = + it "gets the right value" $ do + config <- configWith [("some.key", keyContent)] + fetchFromConfig @a "some.key" config + `shouldThrow` checkException + +ensureFetchParses :: + forall a. + ( FromConfig a + , Typeable a + , Eq a + , Show a + ) + => [(Key, Text)] + -> [(Key, Dynamic)] + -> a + -> SpecWith () +ensureFetchParses configs defaults expectedValue = + it "gets the right value" $ do + config <- addDefaults (mapKeys defaults) <$> configWith (mapKeys configs) + fetchedValue <- fetchFromConfig @a "some.key" config + fetchedValue `shouldBe` expectedValue + where + mapKeys :: [(Key, any)] -> [(Key, any)] + mapKeys = fmap (\(k, x) -> ("some.key" /. k, x)) + +ensureFetchThrows :: + forall a e. + ( FromConfig a + , Typeable a + , Exception e + ) + => [(Key, Text)] + -> [(Key, Dynamic)] + -> (e -> Bool) + -> SpecWith () +ensureFetchThrows configs defaults exceptionCheck = + it "throws an exception" $ do + config <- addDefaults (mapKeys defaults) <$> configWith (mapKeys configs) + fetchFromConfig @a "some.key" config + `shouldThrow` exceptionCheck + where + mapKeys :: forall x. [(Key, x)] -> [(Key, x)] + mapKeys = fmap (\(k, x) -> ("some.key" /. k, x)) diff --git a/test/Conferer/FromConfig/FileSpec.hs b/test/Conferer/FromConfig/FileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/FileSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TypeApplications #-} +module Conferer.FromConfig.FileSpec (spec) where + +import Test.Hspec +import Conferer.FromConfig.Extended +import Conferer.FromConfig () +import System.FilePath (()) +import Data.Text (pack) + +spec :: Spec +spec = do + context "File fromConfig" $ do + describe "fetching a File from config" $ do + ensureFetchParses @File [] [("", toDyn $ File "file.png")] $ + File "file.png" + ensureFetchThrows @File [] [] $ + aMissingRequiredKeys @String + [ "some.key" + , "some.key.extension" + , "some.key.dirname" + , "some.key.basename" + , "some.key.filename" + ] + + context "with whole path in root" $ do + ensureFetchParses @File + [ ("", pack $ "some" "file.png") + ] + [] + $ File $ "some" "file.png" + + context "with whole path in root and overriding extension" $ do + ensureFetchParses @File + [ ("", pack $ "some" "file.png") + , ("extension", "jpg") + ] + [] + $ File $ "some" "file.jpg" + + context "with whole path in root and overriding extension and basename" $ do + ensureFetchParses @File + [ ("", pack $ "some" "file.png") + , ("extension", "jpg") + , ("basename", "somefile") + ] + [] + $ File $ "some" "somefile.jpg" + + context "with whole path in root and overriding dirname" $ do + ensureFetchParses @File + [ ("", pack $ "some" "file.png") + , ("dirname", "dir") + ] + [] + $ File $ "dir" "file.png" + + context "with both filename and basename the most specific takes priority" $ do + ensureFetchParses @File + [ ("", pack $ "some" "file.png") + , ("filename", "somefile.jpg") + , ("basename", "coolfile") + ] + [] + $ File $ "some" "coolfile.jpg" + + context "with both filename and extension the most specific takes priority" $ do + ensureFetchParses @File + [ ("", pack $ "some" "file.png") + , ("filename", "somefile.jpg") + , ("extension", "gif") + ] + [] + $ File $ "some" "somefile.gif" + + context "without root path specificied, with subcomponents that complete a path" $ do + ensureFetchParses @File + [ ("filename", "somefile.jpg") + , ("dirname", pack $ "some" "path") + ] + [] + $ File $ "some" "path" "somefile.jpg" diff --git a/test/Conferer/FromConfig/ListSpec.hs b/test/Conferer/FromConfig/ListSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/ListSpec.hs @@ -0,0 +1,171 @@ + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Conferer.FromConfig.ListSpec (spec) where + +import Test.Hspec +import Conferer.FromConfig.Extended + +data Thing = Thing + { thingA :: Int + , thingB :: String + } deriving (Generic, Show, Eq) + +instance FromConfig Thing + +spec :: Spec +spec = do + describe "list parsing" $ do + ensureEmptyConfigThrows @[Int] + ensureUsingDefaultReturnsSameValue @[Int] [7] + + context "with an empty keys it always gets an empty list" $ do + ensureFetchParses + @[Int] + [ ("keys", "") + ] + [ ("", toDyn @[Int] [1, 2, 3]) ] + [] + context "with a fully defined list without a default" $ do + ensureFetchParses + @[Int] + [ ("0", "2") + ] + [] + [2] + + context "with a non number key" $ do + ensureFetchParses + @[Int] + [ ("a", "0") + , ("b", "1") + ] + [] + [0, 1] + + context "orders the values lexicographically" $ do + ensureFetchParses + @[Int] + [ ("09", "0") + , ("10", "1") + ] + [] + [0, 1] + context "with a prototype as default" $ do + ensureFetchParses + @[Thing] + [ ("0.a", "0") + , ("1.b", "aaa") + ] + [ ("prototype", toDyn (Thing 7 "lala")) + ] + [ Thing { thingA = 0, thingB = "lala"} + , Thing { thingA = 7, thingB = "aaa"} + ] + + context "with a partial prototype that gets completed later" $ do + ensureFetchParses + @[Thing] + [ ("0.a", "0") + , ("prototype.b", "lala") + ] + [] + [ Thing { thingA = 0, thingB = "lala"} + ] + + context "when the user updates the prototype via config" $ do + ensureFetchParses + @[Thing] + [ ("0.a", "0") + , ("prototype.b", "aaa") + ] + [("prototype", toDyn Thing {thingA = 7, thingB = "lala"}) + ] + [ Thing { thingA = 0, thingB = "aaa"} + ] + context "listing keys explicitly uses keys in that order" $ do + ensureFetchParses + @[Thing] + [ ("1.a", "0") + , ("1.b", "a") + , ("a.a", "1") + , ("a.b", "b") + , ("keys", "1,a") + ] + [ ] + [ Thing 0 "a" + , Thing 1 "b" + ] + context "listing keys explicitly uses the prototype if the key is not complete" $ do + ensureFetchParses + @[Thing] + [ ("1.a", "0") + , ("keys", "1") + ] + [ ("prototype", toDyn $ Thing 7 "lele") + ] + [ Thing 0 "lele" + ] + context "listing keys explicitly I can use values from the default" $ do + ensureFetchParses + @[Thing] + [ ("keys", "defaults.0") + ] + [ ("", toDyn + [ Thing {thingA = 0, thingB = "a"} + , Thing {thingA = 1, thingB = "b"} + ]) + ] + [ Thing 0 "a" + ] + context "listing keys explicitly I can use values from the default \ + \ and override some of the values" $ do + ensureFetchParses + @[Thing] + [ ("keys", "defaults.0") + , ("defaults.0.a", "7") + ] + [ ("", toDyn + [ Thing {thingA = 0, thingB = "a"} + , Thing {thingA = 1, thingB = "b"} + ]) + ] + [ Thing 7 "a" + ] + context "listing keys explicitly and using a default from an index \ + \that's not present" $ do + ensureFetchThrows + @[Thing] + [ ("keys", "defaults.5") + ] + [ ("", toDyn + [ Thing {thingA = 0, thingB = "a"} + , Thing {thingA = 1, thingB = "b"} + ]) + ] + $ aMissingRequiredKey @Int "some.key.defaults.5.a" + context "listing a default keys that's not present ignores the \ + \prototype" $ do + ensureFetchThrows + @[Thing] + [ ("keys", "defaults.5") + ] + [ ("prototype", toDyn $ Thing 7 "lele") + , ("", toDyn + [ Thing {thingA = 0, thingB = "a"} + , Thing {thingA = 1, thingB = "b"} + ]) + ] + $ aMissingRequiredKey @Int "some.key.defaults.5.a" + context "fetching maps every key (and they can be used if the lower \ + \fromconfig uses listSubkeys" $ do + ensureFetchParses + @[[Int]] + [ ("1.0", "0") + ] + [ ("prototype.1", toDyn @Int 8) + ] + [[0, 8]] diff --git a/test/Conferer/FromConfig/MaybeSpec.hs b/test/Conferer/FromConfig/MaybeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/MaybeSpec.hs @@ -0,0 +1,33 @@ + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Conferer.FromConfig.MaybeSpec (spec) where + +import Test.Hspec +import Conferer.FromConfig.Extended + +data Thing = Thing + { thingA :: Int + , thingB :: String + } deriving (Generic, Show, Eq) + +instance FromConfig Thing + +spec :: Spec +spec = do + describe "fetching a Maybe from config" $ do + context "when the key is there and has a valid value" $ do + ensureFetchParses @(Maybe Int) [("", "7")] [] $ Just 7 + context "when the key is missing" $ do + ensureFetchParses @(Maybe Int) [] [] Nothing + context "when the key is there but has a wrong value" $ do + ensureFetchThrows @(Maybe Int) [("", "Bleh")] [] anyConfigParserError + context "with default of the inner type" $ do + ensureFetchParses @(Maybe Int) [] [("", toDyn @Int 7)] $ Just 7 + context "with default of a Just inner type" $ do + ensureFetchParses @(Maybe Int) [] [("", toDyn @(Maybe Int) $ Just 7)] $ Just 7 + context "with default of a Nothing and no configuration" $ do + ensureFetchParses @(Maybe Int) [] [("", toDyn @(Maybe Int) $ Nothing)] $ Nothing diff --git a/test/Conferer/FromConfig/NumbersSpec.hs b/test/Conferer/FromConfig/NumbersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/NumbersSpec.hs @@ -0,0 +1,29 @@ + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Conferer.FromConfig.NumbersSpec (spec) where + +import Test.Hspec +import Conferer.FromConfig.Extended + +spec :: Spec +spec = do + context "Numbers fetching" $ do + describe "fetching an Int from config" $ do + ensureEmptyConfigThrows @Int + ensureUsingDefaultReturnsSameValue @Int 7 + ensureSingleConfigParsesTheRightThing @Int "7" 7 + ensureSingleConfigParsesTheRightThing @Int "-7" (-7) + ensureSingleConfigThrowsParserError @Int "50A" + + describe "fetching a Float from config" $ do + ensureEmptyConfigThrows @Float + ensureUsingDefaultReturnsSameValue @Float 7.5 + ensureSingleConfigParsesTheRightThing @Float "9.5" 9.5 + ensureSingleConfigParsesTheRightThing @Float "-9.5" (-9.5) + ensureSingleConfigThrowsParserError @Float "9.50J" + ensureSingleConfigThrowsParserError @Float ".5" + ensureSingleConfigThrowsParserError @Float "9." diff --git a/test/Conferer/FromConfig/StringLikeSpec.hs b/test/Conferer/FromConfig/StringLikeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/StringLikeSpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeApplications #-} + +module Conferer.FromConfig.StringLikeSpec (spec) where + +import Test.Hspec +import Data.Text (Text) +import Conferer.FromConfig.Extended +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS + +spec :: Spec +spec = do + describe "fetching a String from config" $ do + ensureEmptyConfigThrows @String + ensureUsingDefaultReturnsSameValue @String "aaa" + ensureSingleConfigParsesTheRightThing @String "thing" "thing" + describe "fetching text from config" $ do + ensureEmptyConfigThrows @Text + ensureUsingDefaultReturnsSameValue @Text "aaa" + ensureSingleConfigParsesTheRightThing @Text "thing" "thing" + describe "fetching bytestring from config" $ do + ensureEmptyConfigThrows @BS.ByteString + ensureUsingDefaultReturnsSameValue @BS.ByteString "aaa" + ensureSingleConfigParsesTheRightThing @BS.ByteString "thing" "thing" + describe "fetching lazy bytestring from config" $ do + ensureEmptyConfigThrows @LBS.ByteString + ensureUsingDefaultReturnsSameValue @LBS.ByteString "aaa" + ensureSingleConfigParsesTheRightThing @LBS.ByteString "thing" "thing" diff --git a/test/Conferer/FromConfigSpec.hs b/test/Conferer/FromConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfigSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeApplications #-} +module Conferer.FromConfigSpec (spec) where + +import Test.Hspec +import Conferer.FromConfig +import Conferer.FromConfig.Extended + +spec :: Spec +spec = do + describe "Override FromConfig" $ do + ensureFetchParses @Int + [] + [ ("", overrideFetch @Int $ \_k _c -> pure 42) ] + 42 diff --git a/test/Conferer/GenericsSpec.hs b/test/Conferer/GenericsSpec.hs --- a/test/Conferer/GenericsSpec.hs +++ b/test/Conferer/GenericsSpec.hs @@ -4,14 +4,10 @@ import Test.Hspec -import Conferer -import Conferer.Types (FromConfig, DefaultConfig, configDef) +import Conferer.FromConfig -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 +import Conferer.FromConfig.Extended data Thing = Thing { thingA :: Int @@ -19,6 +15,7 @@ } deriving (Generic, Show, Eq) instance FromConfig Thing + instance DefaultConfig Thing where configDef = Thing 0 0 @@ -28,79 +25,74 @@ } deriving (Generic, Show, Eq) instance FromConfig Bigger + instance DefaultConfig Bigger where - configDef = Bigger (configDef { thingA = 27}) 1 + configDef = Bigger (configDef {thingA = 27}) 1 spec :: Spec spec = do describe "Generics" $ do context "with a simple record" $ do + context "without a default but with all of the keys defined" $ do + ensureFetchParses + [ ("a", "0") + , ("b", "0") + ] + [] + Thing { thingA = 0, thingB = 0 } context "when no keys are set" $ do - it "returns the default" $ do - c <- emptyConfig - & addSource (mkMapSource [ ]) - - res <- fetch @Thing "somekey" c - res `shouldBe` Thing { thingA = 0, thingB = 0 } + ensureFetchParses + [] + [ ("", toDyn $ configDef @Thing) + ] + Thing { thingA = 0, thingB = 0 } context "when all keys are set" $ do - it "return the keys set" $ do - c <- emptyConfig - & addSource (mkMapSource - [ ("somekey.a", "1") - , ("somekey.b", "2") - ]) - - res <- fetch @Thing "somekey" c - res `shouldBe` Thing { thingA = 1, thingB = 2 } + ensureFetchParses + [ ("a", "1") + , ("b", "2") + ] + [ ("", toDyn $ configDef @Thing) + ] + Thing { thingA = 1, thingB = 2 } context "when some keys are set" $ do - it "uses the default and returns the keys set" $ do - c <- emptyConfig - & addSource (mkMapSource - [ ("somekey.b", "2") - ]) - - res <- fetch @Thing "somekey" c - res `shouldBe` Thing { thingA = 0, thingB = 2 } + ensureFetchParses + [ ("b", "2") + ] + [ ("", toDyn $ configDef @Thing) + ] + 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 - & addSource (mkMapSource - [ ]) - - res <- fetch @Bigger "somekey" c - res `shouldBe` Bigger { biggerThing = Thing { thingA = 27, thingB = 0 }, biggerB = 1} + ensureFetchParses + [ ] + [ ("", toDyn @Bigger configDef ) + ] + 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 - & addSource (mkMapSource - [ ("somekey.b", "30") - ]) - - res <- fetch @Bigger "somekey" c - res `shouldBe` Bigger { biggerThing = Thing { thingA = 27, thingB = 0 }, biggerB = 30} + ensureFetchParses + [ ("b", "30") + ] + [ ("", toDyn @Bigger configDef) + ] + 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 - & addSource (mkMapSource - [ ("somekey.thing.a", "30") - ]) - - res <- fetch @Bigger "somekey" c - res `shouldBe` Bigger { biggerThing = Thing { thingA = 30, thingB = 0 }, biggerB = 1} + ensureFetchParses + [ ("thing.a", "30") + ] + [ ("", toDyn @Bigger configDef) + ] + 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 - & addSource (mkMapSource - [ ("somekey.thing.a", "10") - , ("somekey.thing.b", "20") - , ("somekey.b", "30") - ]) - - res <- fetch @Bigger "somekey" c - res `shouldBe` Bigger { biggerThing = Thing { thingA = 10, thingB = 20 }, biggerB = 30} + ensureFetchParses + [ ("thing.a", "10") + , ("thing.b", "20") + , ("b", "30") + ] + [ ("", toDyn @Bigger configDef) + ] + Bigger { biggerThing = Thing { thingA = 10, thingB = 20 }, biggerB = 30} diff --git a/test/Conferer/KeySpec.hs b/test/Conferer/KeySpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/KeySpec.hs @@ -0,0 +1,39 @@ +module Conferer.KeySpec where + +import Test.Hspec + +import Conferer.Key +import Conferer.Key.Internal + +spec :: Spec +spec = do + describe "#fromString" $ do + it "parsing keys does the right thing" $ do + "some.key" `shouldBe` Key ["some", "key"] + it "an empty string is the empty list" $ do + "" `shouldBe` Key [] + it "empty key fragments are removed" $ do + "some..key" `shouldBe` Key ["some", "key"] + it "are matched in a case insensitive way" $ do + "some.key" `shouldBe` ("SoME.KeY" :: Key) + it "'s true representation is case insensitive" $ do + "somE.Key" `shouldBe` Key ["some", "key"] + describe "#isValidKeyFragment" $ do + context "with a all leters" $ do + it "is valid" $ + isValidKeyFragment "fragment" `shouldBe` True + context "with only numbers" $ do + it "is valid" $ + isValidKeyFragment "000" `shouldBe` True + context "with both numbers and letters" $ do + it "is valid" $ + isValidKeyFragment "000" `shouldBe` True + context "with a dot" $ do + it "is not valid" $ do + isValidKeyFragment "some.fragment" `shouldBe` False + context "with an uppercase letter" $ do + it "is not valid" $ do + isValidKeyFragment "FRAGMENT" `shouldBe` False + context "with an empty string" $ do + it "is not valid" $ do + isValidKeyFragment "" `shouldBe` False diff --git a/test/Conferer/Source/ArgsSpec.hs b/test/Conferer/Source/ArgsSpec.hs deleted file mode 100644 --- a/test/Conferer/Source/ArgsSpec.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Conferer.Source.ArgsSpec where - -import Test.Hspec - -import Conferer - -spec :: Spec -spec = do - describe "with a mapping source" $ do - let mkConf args = - emptyConfig - & addSource - (mkCLIArgsSource' args) - - it "gets a parameters with it's value if it starts with the right prefix" $ do - c <- mkConf [] - res <- getKey "some.key" c - res `shouldBe` Nothing - - it "with a value that begins with the right prefix it uses it" $ do - c <- mkConf ["--some.key=value"] - res <- getKey "some.key" c - res `shouldBe` Just "value" - - it "with a reapeated value it uses the last one" $ do - c <- mkConf ["--some.key=value", "--some.key=different value"] - res <- getKey "some.key" c - res `shouldBe` Just "different value" - - it "ignores values that don't start with the right prefix" $ do - c <- mkConf ["some.key=value", "-some.key=value", "-Xsome.key=value", "some.key"] - res <- getKey "some.key" c - res `shouldBe` Nothing - - it "after encountering a -- it stops parsing parameters" $ do - c <- mkConf ["--", "--some.key=value"] - res <- getKey "some.key" c - res `shouldBe` Nothing diff --git a/test/Conferer/Source/CLIArgsSpec.hs b/test/Conferer/Source/CLIArgsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/Source/CLIArgsSpec.hs @@ -0,0 +1,42 @@ +module Conferer.Source.CLIArgsSpec where + +import Test.Hspec + +import Conferer.Source +import Conferer.Source.CLIArgs + +spec :: Spec +spec = do + describe "with a mapping source" $ do + let mkConf args = + return $ fromArgs args + + it "gets a parameters with it's value if it starts with the right prefix" $ do + c <- mkConf [] + res <- getKeyInSource c "some.key" + res `shouldBe` Nothing + + it "with a value that begins with the right prefix it uses it" $ do + c <- mkConf ["--some.key=value"] + res <- getKeyInSource c "some.key" + res `shouldBe` Just "value" + + it "with a reapeated value it uses the last one" $ do + c <- mkConf ["--some.key=value", "--some.key=different value"] + res <- getKeyInSource c "some.key" + res `shouldBe` Just "different value" + + it "ignores values that don't start with the right prefix" $ do + c <- mkConf ["some.key=value", "-some.key=value", "-Xsome.key=value", "some.key"] + res <- getKeyInSource c "some.key" + res `shouldBe` Nothing + + it "after encountering a -- it stops parsing parameters" $ do + c <- mkConf ["--", "--some.key=value"] + res <- getKeyInSource c "some.key" + res `shouldBe` Nothing + + it "with passed flag without a value it returns true" $ do + c <- mkConf ["--some.key"] + res <- getKeyInSource c "some.key" + res `shouldBe` Just "true" diff --git a/test/Conferer/Source/EnvSpec.hs b/test/Conferer/Source/EnvSpec.hs --- a/test/Conferer/Source/EnvSpec.hs +++ b/test/Conferer/Source/EnvSpec.hs @@ -1,41 +1,58 @@ module Conferer.Source.EnvSpec where -import Test.Hspec -import qualified Data.Map as Map - -import Conferer +import Test.Hspec +import Test.QuickCheck -fakeLookupEnv :: [(String, String)] -> LookupEnvFunc -fakeLookupEnv fakeEnv = \envName -> - return $ Map.lookup envName $ Map.fromList fakeEnv +import Conferer.Source +import Conferer.Source.Env spec :: Spec spec = do - describe "with an env config" $ do + describe "with an env source" $ do let - mkEnvConfig = - emptyConfig - & addSource - (mkEnvSource' - (fakeLookupEnv - [ ("TMUX","/tmp/tmux-1000/default,2822,0") - , ("TMUX_PANE","%1") - , ("TMUX_PLUGIN_MANAGER_PATH","/home/user/.tmux/plugins/") - ]) - "TMUX" - ) - it "getting an existent key returns unwraps top level value (wihtout \ + mkEnvConfig envVars = + return $ fromEnvList envVars "APP" + + it "getting an existent key returns unwraps top level value (without \ \children)" $ do c <- mkEnvConfig - res <- getKey "." c - res `shouldBe` Just "/tmp/tmux-1000/default,2822,0" + [ ("APP_THING","thing") + , ("APP","root") + , ("APP_PG_HOST","some host") + , ("APP_PG_PORT","some port") + , ("SOMETHING_ELSE","else") + ] + res <- getKeyInSource c "" + res `shouldBe` Just "root" it "getting an existent key for a child gets that value" $ do c <- mkEnvConfig - res <- getKey "pane" c - res `shouldBe` Just "%1" + [ ("APP_THING","thing") + ] + res <- getKeyInSource c "thing" + res `shouldBe` Just "thing" - it "keys should always be consistent as to how the words are separated" $ do + it "listing some keys returns all the right values" $ do c <- mkEnvConfig - res <- getKey "pane" c - res `shouldBe` Just "%1" + [ ("APP_PG_HOST","some host") + , ("APP_PG_PORT","some port") + ] + res <- getSubkeysInSource c "pg" + res `shouldBe` ["pg.host", "pg.port"] + + it "listing the keys under the root list everything excluding ." $ do + c <- mkEnvConfig + [ ("APP_SOME","value") + , ("APP","value") + , ("SOMETHING_ELSE","else") + ] + res <- getSubkeysInSource c "" + res `shouldBe` ["some"] + + it "key to env var and back be identity" $ property $ + forAll + (elements ["a", "a.b", "", "a.b.c", "UPPER"]) + $ \k -> + envVarToKey "theapp" (keyToEnvVar "theapp" k) + == Just k + diff --git a/test/Conferer/Source/InMemorySpec.hs b/test/Conferer/Source/InMemorySpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/Source/InMemorySpec.hs @@ -0,0 +1,32 @@ +module Conferer.Source.InMemorySpec where + +import Test.Hspec + +import Conferer.Source +import Conferer.Source.InMemory + +spec :: Spec +spec = do + describe "in memory source" $ do + let source = + fromAssociations [("postgres.url", "some url")] + + it "getting a non existent key returns an empty config" $ do + res <- getKeyInSource source "some.key" + res `shouldBe` Nothing + + it "getting an existent key returns unwraps the original map" $ do + res <- getKeyInSource source "postgres.url" + res `shouldBe` Just "some url" + + it "listing subkeys works" $ do + res <- getSubkeysInSource source "postgres" + res `shouldBe` ["postgres.url"] + + it "listing subkeys never returns the same key" $ do + res <- getSubkeysInSource source "postgres.url" + res `shouldBe` [] + + it "listing subkeys that are not present" $ do + res <- getSubkeysInSource source "stuff" + res `shouldBe` [] diff --git a/test/Conferer/Source/MappingSpec.hs b/test/Conferer/Source/MappingSpec.hs deleted file mode 100644 --- a/test/Conferer/Source/MappingSpec.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Conferer.Source.MappingSpec where - -import Test.Hspec -import qualified Data.Map as Map -import Data.Function ((&)) - -import Conferer - -spec :: Spec -spec = do - describe "with a mapping source" $ do - it "getting an existent key in the original map but that's not mapped in the \ - \wrapper doesn't exist" $ do - c <- emptyConfig - & addSource (mkMappingSource Map.empty - $ mkMapSource [("some.key", "some value")]) - res <- getKey "some.key" c - res `shouldBe` Nothing - - it "getting a non existent key isn't there" $ do - c <- emptyConfig - & addSource (mkMappingSource (Map.fromList [("k", "key")]) - $ mkMapSource [("key", "75")]) - - res <- getKey "xxxx" c - res `shouldBe` Nothing - - it "getting an existent key that's mapped but doesn't exist on the \ - \inner source isn't there" $ do - c <- emptyConfig - & addSource (mkMappingSource (Map.fromList [("another.key", "some.key")]) - $ mkMapSource []) - - res <- getKey "another.key" c - res `shouldBe` Nothing - - it "getting an existent key that's mapped properly gets it and exists on \ - \the inner source gets it" $ do - c <- emptyConfig - & addSource (mkMappingSource (Map.fromList [("another.key", "some.key")]) - $ mkMapSource [("some.key", "some value")]) - res <- getKey "another.key" c - res `shouldBe` Just "some value" diff --git a/test/Conferer/Source/NamespacedSpec.hs b/test/Conferer/Source/NamespacedSpec.hs --- a/test/Conferer/Source/NamespacedSpec.hs +++ b/test/Conferer/Source/NamespacedSpec.hs @@ -2,20 +2,24 @@ import Test.Hspec -import Conferer +import Conferer.Source +import qualified Conferer.Source.InMemory as InMemory +import Conferer.Source.Namespaced + spec :: Spec spec = do describe "namespaced config" $ do + let source = + fromInner "postgres" $ + InMemory.fromAssociations [("url", "some url")] it "return nothing if the key doesn't match" $ do - c <- emptyConfig - & addSource (mkNamespacedSource "postgres" - $ mkMapSource [("url", "some url")]) - res <- getKey "url" c + res <- getKeyInSource source "url" res `shouldBe` Nothing it "returns the wrapped value" $ do - c <- emptyConfig - & addSource (mkNamespacedSource "postgres" - $ mkMapSource [("url", "some url")]) - res <- getKey "postgres.url" c + res <- getKeyInSource source "postgres.url" res `shouldBe` Just "some url" + it "listing subkeys" $ do + res <- getSubkeysInSource source "postgres" + res `shouldBe` ["postgres.url"] + diff --git a/test/Conferer/Source/NullSpec.hs b/test/Conferer/Source/NullSpec.hs --- a/test/Conferer/Source/NullSpec.hs +++ b/test/Conferer/Source/NullSpec.hs @@ -2,12 +2,11 @@ import Test.Hspec -import Conferer +import Conferer.Source +import Conferer.Source.Null spec :: Spec spec = do it "always fails to get a key" $ do - c <- emptyConfig - & addSource mkNullSource - res <- getKey "some.key" c + res <- getKeyInSource empty "some.key" res `shouldBe` Nothing diff --git a/test/Conferer/Source/PropertiesFileSpec.hs b/test/Conferer/Source/PropertiesFileSpec.hs --- a/test/Conferer/Source/PropertiesFileSpec.hs +++ b/test/Conferer/Source/PropertiesFileSpec.hs @@ -1,39 +1,32 @@ module Conferer.Source.PropertiesFileSpec where -import Test.Hspec -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Map as Map +import Test.Hspec -import Conferer -import Conferer.Core +import Conferer.Source import Conferer.Source.PropertiesFile -fakeLookupEnv :: [(String, String)] -> LookupEnvFunc -fakeLookupEnv fakeEnv = \envName -> - return $ Map.lookup envName $ Map.fromList fakeEnv - spec :: Spec spec = do describe "with a properties file config" $ do - it "getting an existent key returns unwraps top level value (wihtout \ + let mk = return . fromFileContent "file.properties" + it "getting an existent key returns unwraps top level value (without \ \children)" $ do - c <- mkStandaloneSource $ mkPropertiesFileSource' "some.key=a value" + c <- mk "some.key=a value" res <- getKeyInSource c "some.key" res `shouldBe` Just "a value" it "getting an existent key for a child gets that value" $ do - c <- mkStandaloneSource $ mkPropertiesFileSource' $ Text.unlines - [ "some.key=a value" - , "some.key=b" - ] + c <- mk "some.key=b" res <- getKeyInSource c "some.key" res `shouldBe` Just "b" it "keys should always be consistent as to how the words are separated" $ do - c <- mkStandaloneSource $ mkPropertiesFileSource' $ Text.unlines - [ "some.key=a value" - , "some.key=b" - ] - res <- getKeyInSource c "another.key" - res `shouldBe` Nothing + c <- mk "some.key=a value" + res <- getKeyInSource c "some.key" + res `shouldBe` Just "a value" + + it "respects leading spaces in values" $ do + c <- mk "some.key= a value " + res <- getKeyInSource c "some.key" + res `shouldBe` Just " a value " + diff --git a/test/Conferer/Source/SimpleSpec.hs b/test/Conferer/Source/SimpleSpec.hs deleted file mode 100644 --- a/test/Conferer/Source/SimpleSpec.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Conferer.Source.SimpleSpec where - -import Test.Hspec - -import Conferer - -spec :: Spec -spec = do - describe "json source" $ do - let creator = - emptyConfig - & addSource (mkMapSource [ ("postgres.url", "some url")]) - - it "getting a non existent key returns an empty config" $ do - c <- creator - res <- getKey "some.key" c - res `shouldBe` Nothing - - it "getting an existent key returns unwraps the original map" $ do - c <- creator - res <- getKey "postgres.url" c - res `shouldBe` Just "some url" diff --git a/test/ConfererSpec.hs b/test/ConfererSpec.hs --- a/test/ConfererSpec.hs +++ b/test/ConfererSpec.hs @@ -1,33 +1,47 @@ +{-# LANGUAGE TypeApplications #-} +-- {-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE TypeApplications #-} + module ConfererSpec where import Test.Hspec -import Conferer +import Data.Text (Text) +import Conferer.FromConfig (fetchFromConfig) +import Conferer.Source.InMemory (fromConfig) +import Data.Dynamic (toDyn) +import Conferer.Config (Config) +import Conferer (mkConfig', Key) + spec :: Spec spec = do - describe "keys" $ do - it "parsing keys does the right thing" $ do - "some.key" `shouldBe` Path ["some", "key"] - it "an empty string is the empty list" $ do - "" `shouldBe` Path [] + describe "mkConfig'" $ do + let a = fromConfig [("keyPresentInBoth", "valueInA"), ("keyPresentOnlyInA", "valueInA")] + b = fromConfig [("keyPresentInBoth", "valueInB"), ("keyPresentOnlyInB", "valueInB")] + shouldHaveKeyWithValue :: Config -> Key -> Text -> Expectation + shouldHaveKeyWithValue config key expected = do + actual <- fetchFromConfig key config + actual `shouldBe` expected + describe "the precedence of the sources is defined by the order in the list" $ do + it "if several sources have a value for the key, the first source in the list that has it is used" $ do + config <- mkConfig' [] [a, b] - describe "with a config with a nested value" $ do - let mkConfig = - pure emptyConfig - >>= addSource (mkMapSource [ ("postgres.url", "some url")]) - >>= addSource (mkMapSource [ ("postgres.url", "different url") , ("server.port", "4000")]) + config `shouldHaveKeyWithValue` "keyPresentInBoth" $ "valueInA" + it "if only one source has a value for the key, that source is used" $ do + config <- mkConfig' [] [a, b] - it "getting a non existent key returns an empty config" $ do - c <- mkConfig - res <- getKey "aaa" c - res `shouldBe` Nothing + config `shouldHaveKeyWithValue` "keyPresentOnlyInB" $ "valueInB" + it "if the key is not present in any source, it doesn't retrieve any value" $ do + config <- mkConfig' [] [a, b] - it "getting an existent key returns unwraps the original map" $ do - c <- mkConfig - res <- getKey "postgres.url" c - res `shouldBe` Just "some url" - it "getting an existent key returns in the bottom maps gets it" $ do - c <- mkConfig - res <- getKey "server.port" c - res `shouldBe` Just "4000" + value <- fetchFromConfig "keyNotPresentInAnySource" config + value `shouldBe` (Nothing :: Maybe Text) + describe "adds the defaults to the config" $ do + it "if the key is present in a source and in the default, it uses the first source that has it" $ do + config <- mkConfig' [("keyPresentOnlyInA", toDyn @Text "defaultValue")] [a] + config `shouldHaveKeyWithValue` "keyPresentOnlyInA" $ "valueInA" + it "if the key is not present in any source but it's in a default, it uses the default" $ do + config <- mkConfig' [("keyPresentOnlyInA", toDyn @Text "defaultValue")] [b] + + config `shouldHaveKeyWithValue` "keyPresentOnlyInA" $ "defaultValue" diff --git a/test/ConfererSpecMain.hs b/test/ConfererSpecMain.hs new file mode 100644 --- /dev/null +++ b/test/ConfererSpecMain.hs @@ -0,0 +1,7 @@ +module ConfererSpecMain where + +import Test.Hspec.Runner +import qualified Spec + +main :: IO () +main = hspecWith defaultConfig Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}