Env var parsing with free applicatives
#!/usr/bin/env stack | |
-- stack --resolver lts-14.20 --install-ghc runghc --package either --package free | |
{-# LANGUAGE DeriveFunctor #-} | |
module Main | |
where | |
import Control.Applicative.Free | |
import Data.Bifunctor (first) | |
import Data.Either.Combinators (maybeToRight) | |
import Data.Either.Validation | |
import Data.List.NonEmpty (NonEmpty, toList) | |
import Data.Maybe (fromMaybe, mapMaybe) | |
import System.Environment | |
import Text.Read (readMaybe) | |
-- | The parsing result for a single variable | |
data ParsingError | |
= Missing | |
| ParsingError String | |
deriving Show | |
-- | A parsing error, contextualized with the | |
-- variable description | |
data EnvVarError | |
= EnvVarError | |
{ varDesc :: EnvVarDesc | |
, error :: ParsingError | |
} | |
deriving Show | |
-- | Parser for a single env variable | |
-- All the metadata is separated from the parsing function | |
-- to make it monomorphic and more easily usable | |
data EnvVarParser a | |
= EnvVarParser | |
{ parser :: Maybe String -> Either ParsingError a | |
-- ^ the input string is a Maybe to allow optional values | |
, desc :: EnvVarDesc | |
} deriving Functor | |
-- | Making this a separate type allows to directly return a list of `EnvVarDesc` from `runAp_` | |
data EnvVarDesc | |
= EnvVarDesc | |
{ name :: String | |
, isOptional :: Bool | |
-- ^ This is purely for documentation purposes, | |
-- it is not used during parsing | |
} | |
deriving Show | |
type EnvParser = Ap EnvVarParser | |
-- yeah, I know, lenses. | |
modifyDesc :: (EnvVarDesc -> EnvVarDesc) | |
-> EnvVarParser a | |
-> EnvVarParser a | |
modifyDesc f p = p { desc = f (desc p) } | |
-- | Create a parser for a single environment | |
-- variable given its name and a parsing function | |
mkParser :: (String -> Either String a) | |
-> String | |
-> EnvVarParser a | |
mkParser p name = | |
let parser Nothing = Left Missing | |
parser (Just v) = | |
first ParsingError $ p v | |
in EnvVarParser | |
{ parser = parser | |
, desc = EnvVarDesc | |
{ name = name | |
, isOptional = False | |
} | |
} | |
-- | Turn a single environment variable parser | |
-- into a composable `EnvParser` | |
required :: EnvVarParser a -> EnvParser a | |
required = liftAp | |
-- | Turn a single environment variable parser | |
-- into a composable `EnvParser`, making the | |
-- variable optional | |
optional :: EnvVarParser a -> EnvParser (Maybe a) | |
optional (EnvVarParser parser desc) = | |
let optionalParser Nothing = Right Nothing | |
optionalParser v = Just <$> parser v | |
in liftAp $ EnvVarParser | |
{ parser = optionalParser | |
, desc = desc { isOptional = True } | |
} | |
-- | Turn a single environment variable parser | |
-- into a composable `EnvParser`, making the | |
-- variable optional | |
optionalWithDefault :: a | |
-> EnvVarParser a | |
-> EnvParser a | |
optionalWithDefault def = | |
fmap (fromMaybe def) . optional | |
-- | Parse a string from an environment variable | |
str :: String -> EnvVarParser String | |
str = mkParser Right | |
-- | Parse an integer from an environment variable | |
int :: String -> EnvVarParser Integer | |
int = | |
let parseInt = maybeToRight "not an integer" . readMaybe | |
in mkParser parseInt | |
-- | Add a prefix to environment variables names | |
prefix :: String -> EnvParser a -> EnvParser a | |
prefix prefix = | |
let addPrefix = modifyDesc $ \d -> | |
d { name = prefix <> name d } | |
in hoistAp addPrefix | |
-- | List the needed environment variables | |
getVars :: EnvParser a -> [String] | |
getVars = runAp_ (pure . name . desc) | |
renderDoc :: EnvParser a -> String | |
renderDoc p = | |
let descs = runAp_ (pure . desc) p | |
mkLn d = name d <> if isOptional d | |
then " (optional)" | |
else "" | |
in unlines . fmap mkLn $ descs | |
-- | Given the available env variables, parse | |
-- a single environment variable | |
parseEnvVar :: [(String, String)] | |
-> EnvVarParser a | |
-> Validation (NonEmpty EnvVarError) a | |
parseEnvVar env (EnvVarParser p desc) = | |
let v = lookup (name desc) env | |
toError = pure . EnvVarError desc | |
in eitherToValidation . first toError $ p v | |
-- | Given the available env variables, parse | |
-- a composite value | |
parseEnv :: [(String, String)] | |
-> EnvParser a | |
-> Validation (NonEmpty EnvVarError) a | |
parseEnv env = runAp (parseEnvVar env) | |
-- | Parse a composite variable from the environment | |
readFromEnv :: EnvParser a | |
-> IO a | |
readFromEnv p = do | |
env <- readNeededEnv p | |
case parseEnv env p of | |
Failure f -> fail (renderErrors f) | |
Success a -> pure a | |
-- | Read only the needed variables from | |
-- the environment | |
readNeededEnv :: EnvParser a | |
-> IO [(String, String)] | |
readNeededEnv p = | |
let names = getVars p | |
values = traverse lookupEnv names | |
removeEmpty = mapMaybe sequenceA | |
in removeEmpty . zip names <$> values | |
-- | Render the errors encountered when trying | |
-- to parse a composite value | |
renderErrors :: NonEmpty EnvVarError | |
-> String | |
renderErrors errors = | |
let ls = mkLine <$> toList errors | |
mkLine (EnvVarError desc Missing) = | |
name desc <> " is missing" | |
mkLine (EnvVarError desc (ParsingError e)) = | |
name desc <> " could not be parsed: " <> e | |
in "The following errors were encountered\n" | |
<> unlines ls | |
-- now, the example | |
data PG = PG | |
{ port :: Integer | |
, host :: String | |
, user :: String | |
, password :: String | |
, db :: String | |
} deriving Show | |
newtype Macaroon | |
= Macaroon | |
{ secret :: String | |
} deriving Show | |
data Config | |
= Config | |
{ pg :: PG | |
, macaroon :: Macaroon | |
, toto :: String | |
} deriving Show | |
getPg :: EnvParser PG | |
getPg = prefix "PG_" $ PG | |
<$> optionalWithDefault 5432 (int "PORT") | |
<*> required (str "HOST") | |
<*> required (str "USER") | |
<*> required (str "PASSWORD") | |
<*> required (str "DB") | |
getMacaroon :: EnvParser Macaroon | |
getMacaroon = Macaroon | |
<$> required (str "MACAROON_SECRET") | |
getConfig :: EnvParser Config | |
getConfig = Config <$> getPg | |
<*> getMacaroon | |
<*> required (str "TOTO") | |
main :: IO () | |
main = do | |
putStrLn $ renderDoc getConfig | |
readFromEnv getConfig >>= print |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment