packages feed

conftrack (empty) → 0.0.1

raw patch · 12 files changed

+1104/−0 lines, 12 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, bytestring, conftrack, containers, directory, file-io, filepath, mtl, quickcheck-instances, scientific, template-haskell, text, transformers, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# Revision history for conftrack++## 0.0.1 -- 2024-07-26++* First version. Released on an unsuspecting world.+* Basic functionality: main typeclass & abstractions+* Three source types: environment variables, aeson, and yaml+* Additionally, a trivial source easily usable for round-trip testing+* Some convenience functions also serving as examples
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2024, stuebinm++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of stuebinm nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ conftrack.cabal view
@@ -0,0 +1,77 @@+cabal-version:      3.4+name:               conftrack+version:            0.0.1+synopsis:           Tracable multi-source config management+category:           Configuration+description:+  A library for handling multiple config files and keep track of where+  config values came from.++  Config values can be read from json, yaml, or environment variables;+  it is also possible to implement custom configuration sources via a+  type class.++  Provenance of config values is tracked while reading them; an application+  using this library can easily print a listing detailing which files were+  read and which file provided (or failed to provide) an individual value.++license:            BSD-3-Clause+license-file:       LICENSE+author:             stuebinm+maintainer:         stuebinm@disroot.org+-- copyright:+build-type:         Simple+extra-doc-files:    CHANGELOG.md+-- extra-source-files:++source-repository head+    type:     git+    location: https://stuebinm.eu/git/conftrack++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  Conftrack+                    , Conftrack.Value+                    , Conftrack.Pretty+                    , Conftrack.Source+                    , Conftrack.Source.Trivial+                    , Conftrack.Source.Aeson+                    , Conftrack.Source.Yaml+                    , Conftrack.Source.Env+    -- other-modules:+    -- other-extensions:+    build-depends:    base ^>=4.18+                    , text >= 2.0.2 && < 2.1+                    , bytestring >= 0.11.5 && < 0.12+                    , containers >= 0.6.7 && < 0.7+                    , mtl >= 2.3.1 && < 2.4+                    , transformers >= 0.6.1 && < 0.7+                    , aeson >= 2.2.2 && < 2.3+                    , yaml >= 0.11.11 && < 0.12+                    , scientific >= 0.3.8 && < 0.4+                    , filepath ^>= 1.4.100+                    , file-io >= 0.1.1 && < 0.2+                    , template-haskell >= 2.20.0 && < 2.21+                    , directory >= 1.3.8 && < 1.4+    hs-source-dirs:   src+    default-language: GHC2021++test-suite conftrack-test+    import:           warnings+    default-language: GHC2021+    -- other-modules:+    -- other-extensions:+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    build-depends:+        base ^>=4.18,+        conftrack,+        containers,+        text,+        aeson,+        QuickCheck,+        quickcheck-instances
+ src/Conftrack.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-|+Module: Conftrack+Stability: experimental++A typeclass-based library for reading in configuration values from multiple sources,+attempting to be simple, avoid unecessarily complex types, and be able to track where+each value came from.++-}+module Conftrack+  ( -- * How to use this library+    -- $use++    -- * Defining a configuration format+    Config(..)+  , readValue+  , readOptionalValue+  , readRequiredValue+  , readNested+  , readNestedOptional+    -- * Defining sources+  , SomeSource+    -- * Reading a config+  , runFetchConfig+  , Fetch+    -- * Parsing config values+  , Value(..)+  , ConfigValue(..)+    -- * Basic types+  , Key(..)+  , Warning(..)+  , ConfigError(..)+    -- * Utilities+  , configKeysOf+  , key+  ) where++import Conftrack.Value (ConfigError(..), ConfigValue(..), Key (..), Origin(..), Value(..), KeyPart, prefixedWith, key)+import Conftrack.Source (SomeSource (..), ConfigSource (..))++import Prelude hiding (unzip)+import Control.Monad.State (StateT (..))+import Data.Functor ((<&>))+import Data.List.NonEmpty (NonEmpty, unzip)+import qualified Data.List.NonEmpty as NonEmpty+import Control.Monad (forM, (>=>))+import Data.Either (isRight)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Maybe (isJust, mapMaybe)+import Data.Map (Map)+import qualified Data.Map.Strict as M+++-- | A class to model configurations. See "Conftrack"'s documention for a usage example+class Config a where+  readConfig :: Fetch a++data FetcherState = FetcherState+  { fetcherSources :: [SomeSource]+  , fetcherPrefix :: [KeyPart]+  , fetcherOrigins :: Map Key [Origin]+  , fetcherWarnings :: [Warning]+  , fetcherErrors :: [ConfigError]+  }++-- | A value of type @Fetch a@ can be used to read in a value @a@, with configuration+-- sources handled implicitly.+--+-- Note that this is an instance of 'Applicative' but not 'Monad'. In practical terms+-- this means that values read from the configuration sources cannot be inspected while+-- reading the rest of the config, and in particular which keys are read cannot depend+-- on another key's value. This allows for introspection functions like 'configKeysOf'.+--+-- For configuration keys whose presence depends on each other, use+-- 'Conftrack.readNestedOptional' to model similar behaviour.+newtype Fetch a = Fetch (FetcherState -> IO (a, FetcherState))+  deriving (Functor)++newtype Warning = Warning Text+ deriving Show++instance Applicative Fetch where+  pure a = Fetch (\s -> pure (a, s))++  liftA2 f (Fetch m) (Fetch n) = Fetch $ \s -> do+    (a, s2) <- m s+    (b, s3) <- n s2+    pure (f a b, s3)+++runFetchConfig+  :: forall a. Config a+  => NonEmpty SomeSource+  -> IO (Either+         [ConfigError]+         (a, Map Key [Origin], [Warning]))+runFetchConfig sources = do+  let (Fetch m) = readConfig @a++  (result, FetcherState sources2 _ origins warnings errors) <- m (FetcherState (NonEmpty.toList sources) [] [] [] [])+  unusedWarnings <- collectUnused sources2+  if null errors+    then pure $ Right (result, origins, unusedWarnings <> warnings)+    else pure $ Left errors++-- | a list of all keys which will be read when running @runFetchConfig@ to+-- produce a value of type @a@.+--+-- This runs inside the 'IO' monad, but does not do any actual IO.+configKeysOf :: forall a. Config a => IO [Key]+configKeysOf = do+  let (Fetch m) = readConfig @a+  (_, FetcherState _ _ _ _ errors) <- m (FetcherState [] [] [] [] [])++  let keys = mapMaybe (\case {(NotPresent k) -> Just k; _ -> Nothing }) errors+  pure keys++-- | read an optional config value, resulting in a @Just@ if it is present+-- and a @Nothing@ if it is not.+--+-- This is distinct from using 'readValue' to produce a value of type @Maybe a@:+-- the latter will require the key to be present, but allow it to be @null@+-- or similarly empty.+readOptionalValue :: forall a. ConfigValue a => Key -> Fetch (Maybe a)+readOptionalValue bareKey = Fetch $ \s1@FetcherState{..} -> do++  let k = bareKey `prefixedWith` fetcherPrefix++  stuff <- firstMatchInSources k fetcherSources++  let (maybeValues, sources) = unzip stuff++  let values = maybeValues <&> \case+        Right (val, text) -> fromConfig @a val <&> (\a -> (a, [Origin a text]))+        Left e -> Left e++  val <- case fmap (\(Right a) -> a) $ filter isRight values of+    [] -> pure (Nothing, [])+    (value, origin):_ -> pure (Just value, origin)++  pure (fst val, s1 { fetcherSources = sources+                    , fetcherOrigins = M.insertWith (<>) k (snd val) fetcherOrigins })++-- | read in a config value, and produce an error if it is not present.+readRequiredValue :: ConfigValue a => Key -> Fetch a+readRequiredValue k =+  let+    Fetch m = readOptionalValue k+  in+    Fetch (m >=> (\(a, s) -> case a of+      Nothing ->+        let+          dummy = error "A nonexisting config value was evaluated. This is a bug."+        in+          pure (dummy, s { fetcherErrors = NotPresent (k `prefixedWith` fetcherPrefix s) : fetcherErrors s })+      Just v -> pure (v, s)))++-- | read in a config value, or give the given default value if it is not present.+readValue :: forall a. ConfigValue a => a -> Key -> Fetch a+readValue defaultValue k =+  let+    Fetch m = readOptionalValue @a k+  in+    Fetch (m >=> (\(a, s) -> case a of+      Just val -> pure (val, s)+      Nothing ->+        let+          origins = M.insertWith (<>)+            (k `prefixedWith` fetcherPrefix s)+            [Origin defaultValue "default value"]+            (fetcherOrigins s)+        in+          pure (defaultValue, s { fetcherOrigins = origins })))++firstMatchInSources :: Key -> [SomeSource] -> IO [(Either ConfigError (Value, Text), SomeSource)]+firstMatchInSources _ [] = pure []+firstMatchInSources k (SomeSource (source, sourceState):sources) = do+  (eitherValue, newState) <- runStateT (fetchValue k source) sourceState++  case eitherValue of+    Left _ -> do+      firstMatchInSources k sources+        <&> (\a -> (eitherValue, SomeSource (source, newState)) : a)+    Right _ ->+      pure $ (eitherValue, SomeSource (source, newState)) : fmap (Left Shadowed ,) sources++-- | read a nested set of configuration values, prefixed by a given key. This+-- corresponds to nested objects in json.+readNested :: forall a. Config a => Key -> Fetch a+readNested (Key prefix') = Fetch $ \s1 -> do+  let (Fetch nested) = readConfig @a+  (config, s2) <- nested (s1 { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix' })+  pure (config, s2 { fetcherPrefix = fetcherPrefix s1 })++-- | same as 'readNested', but produce @Nothing@ if the nested keys are not present.+-- This can be used for optionally configurable sub-systems or similar constructs.+--+-- If only some but not all keys of the nested configuration are given, this will+-- produce an error.+readNestedOptional :: forall a. (Show a, Config a) => Key -> Fetch (Maybe a)+readNestedOptional (Key prefix) = Fetch $ \s1 -> do+  let (Fetch nested) = readConfig @a+  let nestedState = s1+       { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix+       , fetcherOrigins = [] -- pass an empy list so we can check if at least one element was present+       , fetcherErrors = []+       }++  (config, s2) <- nested nestedState++  let origins = fetcherOrigins s1 <> fetcherOrigins s2++  -- none of the keys present? then return Nothing & produce no errors+  if length (fetcherOrigins s2) == length (filter (\case {NotPresent _ -> True; _ -> False}) (fetcherErrors s2))+     && length (fetcherOrigins s2) == length (fetcherErrors s2) then+    pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1, fetcherErrors = fetcherErrors s1, fetcherOrigins = fetcherOrigins s1 })+  else+    -- any other errors? if so, forward those+    if not (null (fetcherErrors s2)) then+      pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1+                        , fetcherOrigins = origins+                        , fetcherErrors = fetcherErrors s2 <> fetcherErrors s1+                        })+    else+      -- success!+      pure (Just config, s2 { fetcherPrefix = fetcherPrefix s1+                            , fetcherOrigins = origins+                            })+++collectUnused :: [SomeSource] -> IO [Warning]+collectUnused sources = do+  forM sources (\(SomeSource (source, sourceState)) ->+    runStateT (leftovers source) sourceState <&> fst)+    <&> fmap (\(Just a) -> Warning $ "Unused Keys " <> T.pack (show a))+        . filter (\(Just a) -> not (null a))+        . filter isJust+++{- $use++This library models configuration files as a list of configuration 'Key's,+for which values can be retrieved from generic sources, such as environment+variables, a program's cli arguments, or a yaml (or json, etc.) file.++As a simple example, assume a program interacting with some API. We want it+to read the API's base url (falling back to a default value if it is not+given) and an API key (and error out if it is missing) from its config:++> data ProgramConfig =+>   { configBaseUrl :: URL+>   , configApiKey  :: Text+>   }++Then we can write an appropriate instance of 'Config' for it:++> instance Config ProgramConfig where+>   readConfig = ProgramConfig+>     <$> readValue "http://example.org" [key|baseUrl|]+>     <*> readRequiredValue [key|apiKey|]++'Config' is an instance of 'Applicative'. With the @ApplicativeDo@ language+extension enabled, the above can be equivalently written as:++> instance Config ProgramConfig where+>   readConfig = do+>     configBaseUrl <- readValue "http://example.org" [key|baseUrl|]+>     configApiKey <- readRequiredValue [key|apiKey|]+>     pure (ProgramConfig {..})++Note that 'Config' is not a 'Monad', so we cannot inspect the config values here,+or make the reading of further keys depend on the value of earlier ones. This is+to enable introspection-like uses as in 'configKeysOf'.++To read our config we must provide a non-empty list of sources. Functions to+construct these live in the @Conftrack.Source.*@ modules; here we use+'Conftrack.Source.Yaml.mkYamlFileSource' and 'Conftrack.Source.Env.mkEnvSource'+(from "Conftrac.Source.Yaml" and "Conftrack.Source.Env" respectively) to read+values from either a yaml file or environment variables:++> main = do+>   result <- runFetchConfig+>                [ mkEnvSource "CONFTRACK"+>                , mkYamlFileSource [path|./config.yaml|]+>                ]+>   case result of+>     Left _ -> ..+>     Right (config, origins, warnings) -> ..++Now we can read in a config file like++> baseUrl: http://localhost/api/v1+> apiKey: very-very-secret++or from environment variables++> CONFTRACK_BASEURL=http://localhost/api/v1+> CONFTRACK_APIKEY=very-very-secret++Of course, sources can be mixed: Perhaps we do not want to have our program's api+key inside the configuration file. Then we can simply omit it there and provide it+via the @CONFTRACK_APIKEY@ environment variable instead.++== Multiple sources++The order of sources given to 'runFetchConfig' matters: values given in earlier+sources shadow values of the same key in all following sources.++Thus even if we have++> apiKey: will-not-be-used++in our @config.yaml@ file, it will be ignored if the @CONFTRACK_APIKEY@ environment+variable also has a value.++== Keeping track of things++Conftrack is written to always keep track of the configuration values it reads. In+particular, it is intended to avoid frustrating questions of the kind "I have+clearly set this config key in the file, why does my software not use it?".++This is reflected in 'runFetchConfig'\'s return type: if it does not produce an error,+it will not only return a set of config values, but also a map of 'Origin's and a list+of 'Warning's indicating likely misconfiguration:++> main = do+>   result <- runFetchConfig+>                [ mkEnvSource "CONFTRACK"+>                , mkYamlFileSource [path|./config.yaml|]+>                ]+>   case result of+>     Left _ -> ..+>     Right (config, origins, warnings) -> do+>       printConfigOrigins origins+>       ...++May print something like this:++> Environment variable CONFTRACK_APIKEY+>   apiKey = "very-very-secret"+> YAML file ./config.yaml+>   baseUrl = "http://localhost/api/v1"++It is recommended that programs making use of conftrack include a @--show-config@+option (or a similar method of introspection) to help in debugging such cases.+-}
+ src/Conftrack/Pretty.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}++-- | This module contains convenience functions to print the values returned by+-- 'Conftrack.runFetchConfig'.+--+-- These functions can be used as-is in programs using this library, or serve as+-- examples for people who wish to display the results some another way.+module Conftrack.Pretty (unwrapConfigResult, printConfigOrigins, printConfigWarnings, printConfigErrors, displayError) where++import Conftrack.Value (Origin(..), ConfigError (..), ConfigValue(..), Key)+import Conftrack (Warning (..), Config)+import Data.Map (Map)+import qualified Data.Map.Strict as M+import qualified Data.Text.IO as T+import qualified Data.Text as T+import GHC.Exts (groupWith)+import System.Exit (exitFailure)+import Control.Monad (when)+++-- | A convenience function, to be @>>=@'d with 'Conftrack.runFetchConfig'.+--+-- It prints any errors in case of failure and then aborts the program, and prints+-- any warnings (and, if the first argument is @True@, also each value's origin) and+-- returns the config in case of success.+unwrapConfigResult+  :: forall a. Config a+  => Bool+  -> Either [ConfigError] (a, Map Key [Origin], [Warning])+  -> IO a+unwrapConfigResult _ (Left errors) = do+  printConfigErrors errors+  exitFailure+unwrapConfigResult verbose (Right (config, origins, warnings)) = do+  when verbose $ printConfigOrigins origins+  printConfigWarnings warnings+  pure config++-- TODO: perhaps sort it by source, not by key?+-- also, shadowed values are currently never read+printConfigOrigins :: Map Key [Origin] -> IO ()+printConfigOrigins =+  mapM_ (T.putStrLn . prettyOrigin)+  . groupWith ((\(Origin _ s) -> s) . head . snd)+  . filter (not . null . snd)+  . M.toList+  where prettyOrigin origins =+          T.concat $ originSource (snd (head origins)) : fmap prettyKey origins+        prettyKey (key, []) = "\n  " <> T.pack (show key)+        prettyKey (key, (Origin val _):shadowed) = T.concat $+          ["\n  ", T.pack $ show key, " = ", prettyValue val]+          <> fmap (\(Origin _ text) -> "\n    (occurrance in "<>text<>" shadowed)") shadowed+        originSource [] = "default value"+        originSource (Origin _ text:_) = text++printConfigWarnings :: [Warning] -> IO ()+printConfigWarnings warnings =+  T.putStrLn $ "Warnings:\n  " <> T.intercalate "\n  " (fmap (\(Warning text) -> text) warnings)++printConfigErrors :: [ConfigError] -> IO ()+printConfigErrors errors =+  T.putStrLn $ "Errors while reading configuration:\n  " <> T.intercalate "\n  " (fmap displayError errors)++displayError :: ConfigError -> T.Text+displayError (ParseError text) = "Parse Error: " <> text+displayError (TypeMismatch text val) = "Type Error: got" <> T.pack (show val) <> " but expected " <> text <> "."+displayError (NotPresent key) = "Required key " <> T.pack (show key) <> " is missing."+displayError Shadowed = "Shadowed" -- Note: this branch never occurs (for now)
+ src/Conftrack/Source.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Conftrack.Source (ConfigSource(..), SomeSource(..)) where++import Conftrack.Value (Key, Value(..), ConfigError(..))++import Control.Monad.State (StateT (..))+import Data.Text (Text)+++-- | An abstraction over "config sources". This might mean file formats,+-- environment variables, or any other kind of format that can be seen as a+-- key-value store.+class ConfigSource s where+  -- | Some sources require state, e.g. to keep track of which values were+  -- already read.+  type SourceState s++  -- | read a single value from the source.+  fetchValue :: Key -> s -> StateT (SourceState s) IO (Either ConfigError (Value, Text))++  -- | given @s@, determine if any keys are "left over" and were not used.+  -- This is used to produce warnings for unknown configuration options;+  -- since not all sources can support this, this function's return type+  -- includes @Maybe@ and sources are free to return @Nothing@ if they+  -- cannot determine if any unknown keys are present.+  leftovers :: s -> StateT (SourceState s) IO (Maybe [Key])++-- | An opaque type for any kind of config sources. Values of this type can be+-- acquired from they @Conftrack.Source.*@ modules, or by implementing the+-- 'ConfigSource' type class.+data SomeSource = forall source. ConfigSource source+   => SomeSource (source, SourceState source)++
+ src/Conftrack/Source/Aeson.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++-- | Functions for producing sources reading from json strings or files, using the aeson library.+module Conftrack.Source.Aeson (mkJsonSource, mkJsonSourceWith, mkJsonFileSource, JsonSource(..)) where++import Conftrack.Value (Key (..), ConfigError(..), Value (..), KeyPart)+import Conftrack.Source (SomeSource(..), ConfigSource (..))++import Prelude hiding (readFile)+import qualified Data.Aeson as A+import Control.Monad.State (get, modify, MonadState (..))+import Data.Function ((&))+import Data.Text (Text)+import qualified Data.Aeson.Text as A+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Aeson.Types as A+import qualified Data.Aeson.Key as A+import Data.Aeson.Types (unexpected)+import qualified Data.List.NonEmpty as NonEmpty+import Control.Monad ((>=>))+import Data.Functor ((<&>))+import System.OsPath (OsPath)+import qualified System.OsPath as OS+import System.File.OsPath (readFile)+import qualified Data.Aeson.KeyMap as A+import qualified Data.Text.Encoding as BS++data JsonSource = JsonSource+  { jsonSourceValue :: A.Value+  , jsonSourceDescription :: Text+  } deriving (Show)++-- | Make a source from an aeson value+mkJsonSource :: A.Value -> SomeSource+mkJsonSource value = mkJsonSourceWith ("JSON string " <> LT.toStrict (A.encodeToLazyText value)) value++-- | same as 'mkJsonSource', but with an additional description to be shown+-- in output of 'Conftrack.Pretty.printConfigOrigins'.+mkJsonSourceWith :: Text -> A.Value -> SomeSource+mkJsonSourceWith description value = SomeSource (source, [])+  where source = JsonSource value description++-- | Make a source from a json file.+mkJsonFileSource :: OsPath -> IO (Maybe SomeSource)+mkJsonFileSource path = do+  bytes <- readFile path+  pathAsText <- OS.decodeUtf path <&> LT.toStrict . LT.pack+  pure $ A.decode bytes+    <&> mkJsonSourceWith ("JSON file " <> pathAsText)++instance ConfigSource JsonSource where+  type SourceState JsonSource = [Key]++  fetchValue key@(Key parts) JsonSource{..} = do+    case A.parseEither (lookupJsonPath (NonEmpty.toList parts) >=> parseJsonValue) jsonSourceValue of+      Left a -> pure $ Left (ParseError (T.pack a))+      Right val -> do+        modify (key :)+        pure $ Right (val, jsonSourceDescription)++  leftovers JsonSource{..} = do+    used <- get++    allJsonPaths jsonSourceValue+     & filter (`notElem` used)+     & Just+     & pure++-- | this is essentially a FromJSON instance for Value, but not written as one+-- so as to not introduce an orphan+parseJsonValue :: A.Value -> A.Parser Value+parseJsonValue = \case+  (A.String bytes) -> pure $ ConfigString (BS.encodeUtf8 bytes)+  (A.Number num) ->+    A.parseJSON (A.Number num) <&> ConfigInteger+  (A.Bool b) -> pure $ ConfigBool b+  A.Null -> pure ConfigNull+  (A.Object _) -> unexpected "unexpected json object"+  (A.Array _) -> unexpected "unexpected json array"++lookupJsonPath ::  [KeyPart] -> A.Value -> A.Parser A.Value+lookupJsonPath [] value = pure value+lookupJsonPath (part:parts) value = do+  A.withObject "blub" (\obj -> obj A..: A.fromText part) value+  >>= lookupJsonPath parts++allJsonPaths :: A.Value -> [Key]+allJsonPaths = fmap keyToKey . subKeys []+  where+    keyToKey keys = Key (fmap aesonKeyToText keys)+    aesonKeyToText (key :: A.Key) = case A.parseMaybe A.parseJSON (A.toJSON key) of+      Nothing -> error "key not representable as text; this is a bug in conftrack-aeson."+      Just a -> a+    subKeys prefix (A.Object keymap) =+      A.foldMapWithKey (\key v -> subKeys (prefix <> [key]) v) keymap+    subKeys prefix _ = case NonEmpty.nonEmpty prefix of+      Just key -> [key]+      _ -> undefined
+ src/Conftrack/Source/Env.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++module Conftrack.Source.Env (EnvSource(..), mkEnvSource) where++import Conftrack.Value (Key (..), ConfigError(..), Value (..))+import Conftrack.Source (ConfigSource (..), SomeSource (SomeSource))++import Prelude hiding (readFile)+import Data.Text (Text)+import System.OsString (OsString, decodeUtf, encodeUtf)+import System.Directory.Internal (lookupEnvOs)+import Control.Monad.Trans (MonadIO (liftIO))+import Text.Read (readMaybe)+import Control.Monad.State (modify)+import qualified Data.Text as T+import qualified Data.Text.Encoding as BE+import Data.Functor ((<&>))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromJust)+import Data.Function ((&))++data EnvSource = EnvSource+  { envSourceModifier :: Key -> OsString+  , envSourceDescription :: Text+  }++mkEnvSource :: Text -> SomeSource+mkEnvSource prefix = SomeSource (source, [])+  where source = EnvSource+          { envSourceModifier = \(Key parts) ->+              prefix <> "_" <> T.intercalate "_" (NonEmpty.toList parts)+              & T.toUpper+              & T.unpack+              & encodeUtf+              & fromJust+          , envSourceDescription = "Environment variable "+          }++instance Show EnvSource where+  show EnvSource{..} =+    "EnvSource { envSourceDescription = " <> show envSourceDescription <> "}"++instance ConfigSource EnvSource where+  type SourceState EnvSource = [Key]++  fetchValue key EnvSource{..} =+    liftIO (lookupEnvOs envVarName) >>= \case+      Nothing -> pure $ Left (NotPresent key)+      Just osstr -> do+        modify (key :)+        str <- liftIO $ decodeUtf osstr+        let value = case readMaybe str of+              Just num -> ConfigMaybeInteger (BE.encodeUtf8 $ T.pack str) num+              Nothing -> ConfigString (BE.encodeUtf8 $ T.pack str)+        envNameText <- decodeUtf envVarName <&> T.pack+        pure $ Right (value, envSourceDescription <> envNameText)+      where envVarName = envSourceModifier key++  leftovers _ = pure Nothing
+ src/Conftrack/Source/Trivial.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A trivial source reading from a @Map Key Value@, only useful as a demonstration or for tests.+module Conftrack.Source.Trivial where++import Conftrack.Value (Key, Value(..), ConfigError(..))+import Conftrack.Source (SomeSource(..), ConfigSource (..))++import Control.Monad.State (get, modify, MonadState (..))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Function ((&))+import qualified Data.Text as T+++newtype Trivial = Trivial (Map Key Value)++mkTrivialSource :: [(Key, Value)] -> SomeSource+mkTrivialSource pairs = SomeSource (source, [])+  where source = Trivial (M.fromList pairs)++instance ConfigSource Trivial where+  type SourceState Trivial = [Key]+  fetchValue key (Trivial tree) = do+    case M.lookup key tree of+      Nothing -> pure $ Left (NotPresent key)+      Just val -> do+        modify (key :)+        pure $ Right (val, "Trivial source with keys "<> T.pack (show (M.keys tree)))++  leftovers (Trivial tree) = do+    used <- get++    M.keys tree+     & filter (`notElem` used)+     & Just+     & pure
+ src/Conftrack/Source/Yaml.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Functions for producing sources reading from yaml strings or files, using the aeson library.+module Conftrack.Source.Yaml (YamlSource(..), mkYamlSource, mkYamlSourceWith, mkYamlFileSource) where++import Conftrack.Source (SomeSource(..), ConfigSource (..))+import Conftrack.Source.Aeson++import Prelude hiding (readFile)+import qualified Data.Aeson as A+import qualified Data.Yaml as Y+import Data.Text (Text)+import qualified Data.Aeson.Text as A+import qualified Data.Text.Lazy as LT+import Data.Functor ((<&>))+import System.OsPath (OsPath)+import qualified System.OsPath as OS+import System.File.OsPath (readFile)+import qualified Data.ByteString as BS++newtype YamlSource = YamlSource JsonSource+  deriving newtype (ConfigSource, Show)++mkYamlSource :: A.Value -> SomeSource+mkYamlSource value = mkYamlSourceWith ("Yaml string " <> LT.toStrict (A.encodeToLazyText value)) value++mkYamlSourceWith :: Text -> A.Value -> SomeSource+mkYamlSourceWith description value = SomeSource (source, [])+  where source = YamlSource (JsonSource value description)++mkYamlFileSource :: OsPath -> IO (Either Y.ParseException SomeSource)+mkYamlFileSource path = do+  bytes <- readFile path <&> BS.toStrict+  pathAsText <- OS.decodeUtf path <&> LT.toStrict . LT.pack+  pure $ Y.decodeEither' bytes+    <&> mkYamlSourceWith ("YAML file " <> pathAsText)+
+ src/Conftrack/Value.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DefaultSignatures #-}++module Conftrack.Value (key, Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith, withString) where++import Data.Text(Text)+import qualified Data.Text as T+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LB+import Data.List.NonEmpty (NonEmpty, prependList)+import qualified Data.List.NonEmpty as NonEmpty+import System.OsPath (OsPath, encodeUtf)+import qualified Data.Text.Encoding as BS+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Syntax (Lift(lift))++-- | A generic value read from a config source, to be parsed into a more useful type+-- (see the 'ConfigValue' class).+data Value =+  ConfigString BS.ByteString+  | ConfigInteger Integer+  -- | A value which may be an integer, but the source cannot say for sure, e.g. because+  -- its values are entirely untyped. Use 'withString' to handle such cases.+  | ConfigMaybeInteger BS.ByteString Integer+  | ConfigOther Text Text+  | ConfigBool Bool+  | ConfigNull+  deriving Show++type KeyPart = Text++-- | A configuration key is a non-empty list of parts. By convention, these parts+-- are separated by dots when written, although dots withing parts are not disallowed.+--+-- For writing values easily, consider enabling the @QuasiQuotes@ language extension+-- to use 'key':+--+-- >>> [key|foo.bar|]+-- foo.bar+newtype Key = Key (NonEmpty KeyPart)+  deriving newtype (Eq, Ord)+  deriving (Lift)++instance Show Key where+  show (Key parts) = T.unpack (T.intercalate "." (NonEmpty.toList parts))++-- | to write values of 'Key' easily+key :: QuasiQuoter+key = QuasiQuoter+  { quoteExp = lift . Key . NonEmpty.fromList . T.splitOn "." . T.pack+  , quotePat = \_ -> fail "key quoter cannot be used in patterns"+  , quoteType = \_ -> fail "key quasi-quote cannot be used for types"+  , quoteDec = \_ -> fail "key quasi-quote cannot be used in declarations"}+++prefixedWith :: Key -> [KeyPart] -> Key+prefixedWith (Key k) prefix = Key (prependList prefix k)++data ConfigError =+  ParseError Text+  | TypeMismatch Text Value+  | NotPresent Key+  | Shadowed+  deriving Show++-- | Values which can be read from a config source must implement this class+class ConfigValue a where+  fromConfig :: Value -> Either ConfigError a+  -- | optionally, a function to pretty-print values of this type, used by the+  -- functions of "Conftrack.Pretty". If not given, defaults to @a@'s 'Show' instance.+  prettyValue :: a -> Text++  default prettyValue :: Show a => a -> Text+  prettyValue = T.pack . show++data Origin = forall a. ConfigValue a => Origin a Text++instance Show Origin where+  show (Origin a text) = "Origin " <> T.unpack (prettyValue a) <> " " <> T.unpack text++withString :: (BS.ByteString -> Either ConfigError a) -> Value -> Either ConfigError a+withString f (ConfigString a) = f a+withString f (ConfigMaybeInteger a _) = f a+withString _ val = Left (TypeMismatch "text" val)++withInteger :: (Integer -> Either ConfigError a) -> Value -> Either ConfigError a+withInteger f (ConfigInteger a) = f a+withInteger f (ConfigMaybeInteger _ a) = f a+withInteger _ val = Left (TypeMismatch "integer" val)++instance ConfigValue Text where+  fromConfig = withString (Right . BS.decodeUtf8)++instance ConfigValue Integer where+  fromConfig = withInteger Right++instance ConfigValue Int where+  fromConfig = withInteger (Right . fromInteger)++instance ConfigValue Bool where+  fromConfig (ConfigBool b) = Right b+  fromConfig val = Left (TypeMismatch "bool" val)++instance ConfigValue a => ConfigValue (Maybe a) where+  fromConfig ConfigNull = Right Nothing+  fromConfig just = fmap Just (fromConfig just)++  prettyValue Nothing = "null"+  prettyValue (Just a) = prettyValue a++instance ConfigValue OsPath where+  fromConfig = \case+    (ConfigString text) -> stringToPath text+    (ConfigMaybeInteger text _) -> stringToPath text+    val -> Left (TypeMismatch "path" val)+   where stringToPath text = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of+          Right path -> Right path+          Left err -> Left (ParseError (T.pack $ show err))++instance ConfigValue LB.ByteString where+  fromConfig = withString (Right . LB.fromStrict)++instance ConfigValue BS.ByteString where+  fromConfig = withString Right
+ test/Main.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE QuasiQuotes #-}+module Main (main) where++import Conftrack+import Conftrack.Source.Trivial (mkTrivialSource)+import Conftrack.Source.Aeson (mkJsonSource)++import Data.Text (Text)+import qualified Data.Aeson as A+import Test.QuickCheck+import Test.QuickCheck.Monadic+import Test.QuickCheck.Instances ()+import System.Exit (exitFailure, exitSuccess)+import qualified Data.Text.Encoding as BS+import Data.List ((\\))+import Data.Maybe (isNothing)+++data TestFlat = TestFlat { testFoo :: Text, testBar :: Integer }+  deriving (Show, Eq)++instance Arbitrary TestFlat where+  arbitrary = TestFlat <$> arbitrary <*> arbitrary++data TestNested = TestNested { nestedFoo :: Text, nestedTest :: TestFlat }+  deriving (Show, Eq)++data TestOptionalNested = TestOptionalNested { opNestedFoo :: Text, opNestedTest :: Maybe TestFlat }+  deriving (Show, Eq)++instance Arbitrary TestNested where+  arbitrary = TestNested <$> arbitrary <*> arbitrary++instance Config TestFlat where+  readConfig = TestFlat+    <$> readRequiredValue (Key ["foo"])+    <*> readRequiredValue (Key ["bar"])++instance Config TestNested where+  readConfig = do+    a <- readRequiredValue (Key ["foo"])+    b <- readNested (Key ["nested"])+    pure (TestNested a b)++instance Config TestOptionalNested where+  readConfig = do+    a <- readRequiredValue (Key ["foo"])+    b <- readNestedOptional (Key ["nested"])+    pure (TestOptionalNested a b)++testTypeToTrivial :: TestFlat -> SomeSource+testTypeToTrivial (TestFlat foo bar) = mkTrivialSource+  [(Key ["foo"], ConfigString (BS.encodeUtf8 foo)), (Key ["bar"], ConfigInteger bar)]++testTypeToJson :: TestFlat -> A.Value+testTypeToJson (TestFlat foo bar) =+  A.object ["foo" A..= foo, "bar" A..= bar]++nestedToTrivial :: TestNested -> SomeSource+nestedToTrivial (TestNested nfoo (TestFlat foo bar)) =+  mkTrivialSource [ (Key ["foo"], ConfigString (BS.encodeUtf8 nfoo))+                  , (Key ["nested", "foo"], ConfigString (BS.encodeUtf8 foo))+                  , (Key ["nested", "bar"], ConfigInteger bar)]++nestedToJson :: TestNested -> SomeSource+nestedToJson (TestNested nfoo (TestFlat foo bar)) =+  mkJsonSource $ A.object+    [ "foo" A..= nfoo+    , "nested" A..= A.object+      [ "foo" A..= foo+      , "bar" A..=bar+      ]+    ]++roundtripVia :: (Eq a, Config a) => (a -> SomeSource) -> a -> Property+roundtripVia f val = monadicIO $ do+  let trivial = f val+  Right (config :: a, _, _) <- run $ runFetchConfig [trivial]+  assert (config == val)++prop_flat :: TestFlat -> Property+prop_flat = roundtripVia testTypeToTrivial++prop_nested :: TestNested -> Property+prop_nested = roundtripVia nestedToTrivial++prop_aeson_flat :: TestFlat -> Property+prop_aeson_flat = roundtripVia (mkJsonSource . testTypeToJson)++prop_aeson_nested :: TestNested -> Property+prop_aeson_nested = roundtripVia nestedToJson++prop_flat_keys :: Property+prop_flat_keys = monadicIO $ do+  keys <- run $ configKeysOf @TestFlat+  assert (null (keys \\ [ [key|foo|], [key|bar|] ]))++prop_nested_keys :: Property+prop_nested_keys = monadicIO $ do+  keys <- run $ configKeysOf @TestNested+  assert (null (keys \\ [ [key|foo|], [key|nested.bar|], [key|nested.foo|] ]))++prop_nested_optional_nothing :: Property+prop_nested_optional_nothing = monadicIO $ do+  Right (conf, _, warnings) <- run $ runFetchConfig [ mkJsonSource (A.object ["foo" A..= ("bar" :: Text)]) ]+  assert (null warnings)+  assert (isNothing (opNestedTest conf))++prop_nested_optional_partial :: Property+prop_nested_optional_partial = monadicIO $ do+  Left errors <- run $ runFetchConfig @TestOptionalNested [ mkJsonSource (A.object ["foo" A..= ("bar" :: Text), "nested" A..= A.object [ "foo" A..= ("bar" :: Text) ]]) ]+  assert (not (null errors))++prop_nested_optional_just :: TestFlat -> Property+prop_nested_optional_just nested = monadicIO $ do+  Right (conf, _, warnings) <- run $ runFetchConfig [+    mkJsonSource (A.object ["foo" A..= ("bar" :: Text), "nested" A..= testTypeToJson nested ])+    ]+  assert (null warnings)+  assert (opNestedTest conf == Just nested)++-- see quickcheck docs for why this return is here+return []+runTests :: IO Bool+runTests = $quickCheckAll++main :: IO ()+main = do+  good <- runTests+  if good then exitSuccess else exitFailure