path: root/src/Conftrack.hs

{-# 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.
-}