Haskell App Configuration

Config.hs

#!/usr/bin/env stack
-- stack --resolver lts-12.12 script --package aeson --package mtl
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeFamilies        #-}
module Config
    ( Config
    , Config'(..)
    , resolve
    )
where

import           Control.Applicative       ((<|>))
import           Control.Monad.Error.Class (MonadError, liftEither, throwError)
import           Control.Monad.Except      (runExceptT)
import           Control.Monad.IO.Class    (MonadIO, liftIO)
import qualified Data.Aeson                as Aeson
import           Data.Functor.Identity     (Identity)
import           GHC.Generics              (Generic)
import           System.Environment        (lookupEnv)


type family Setting (f :: * -> *) a where
    Setting Identity a = a
    Setting Maybe    a = Maybe a


data Config' f = Config
    { foo :: Setting f String
    , bar :: Setting f String
    } deriving Generic


type Config = Config' Identity
deriving instance Show Config


type PartialConfig = Config' Maybe
deriving instance Show PartialConfig
deriving instance Aeson.FromJSON PartialConfig

instance Semigroup PartialConfig where
    c1 <> c2 = Config
        { foo = foo c1 <|> foo c2
        , bar = bar c1 <|> bar c2
        }

instance Monoid PartialConfig where
    mempty = Config mempty mempty


-- | Get configuration options from the environment.
fromEnv :: forall m . (MonadIO m, MonadError String m) => m PartialConfig
fromEnv = do
    foo <- lookup "FOO"
    bar <- lookup "BAR"
    pure Config {foo , bar }
  where
    lookup :: String -> m (Maybe String)
    lookup = liftIO . lookupEnv


-- | Get configuration options from a (json) config file.
fromFile :: (MonadIO m, MonadError String m) => FilePath -> m PartialConfig
fromFile configFilePath = do
    result <- liftIO (Aeson.eitherDecodeFileStrict configFilePath)
    liftEither result


-- | Fill in a partial config, maybe throwing errors.
finalize :: forall m . MonadError String m => PartialConfig -> m Config
finalize partial = do
    foo <- withDefault "default" (foo partial)
    bar <- withDefault "default" (bar partial)
    pure Config {foo , bar }
  where
    withDefault :: a -> Maybe a -> m a
    withDefault def = liftEither . maybe (Right def) Right


-- | Run the whole config resolution dance.
resolve :: (MonadIO m, MonadError String m) => Maybe FilePath -> m Config
resolve configFilePath = do
    configEnv  <- fromEnv
    configFile <- maybe (pure mempty) fromFile configFilePath
    finalize (configFile <> configEnv)


main :: IO ()
main = runExceptT (resolve $ Just "config.json") >>= print

config.json

{
    "foo": "FILE"
}