{-# LANGUAGE DeriveFunctor #-}
module Environment
(
Parser,
text,
int,
float,
boolean,
uri,
filePath,
networkURI,
secret,
custom,
Decoder,
consumes,
Variable (Variable, name, description, defaultValue),
variable,
either,
decode,
decodeDefaults,
decodePairs,
decodeVariables,
decodeVariablePairs,
DecodedVariable
( DecodedVariable,
decodedVariable,
decodedCurrent,
decodedErrors
),
)
where
import qualified Data.Text
import qualified Debug
import qualified Dict
import qualified List
import qualified Log
import qualified Maybe
import qualified Network.URI
import NriPrelude
import qualified Result
import qualified System.Environment
import Text.Read (readMaybe)
import qualified Text.URI
import qualified Tuple
import Prelude
( Applicative,
Either (Left, Right),
FilePath,
Functor,
IO,
Integer,
Integral,
Semigroup,
fail,
fromIntegral,
mempty,
pure,
)
newtype Parser a
= Parser (Text -> Result Text a)
deriving (Functor)
text :: Parser Text
text = Parser Ok
int :: (Integral a) => Parser a
int =
Parser <| \str ->
case readMaybe (Data.Text.unpack str) of
Nothing -> Err ("Could not parse as integer: " ++ str)
Just (n :: Integer) -> Ok (fromIntegral n)
float :: Parser Float
float =
Parser <| \str ->
case readMaybe (Data.Text.unpack str) of
Nothing -> Err ("Could not parse as float: " ++ str)
Just n -> Ok n
boolean :: Parser Bool
boolean =
Parser <| \str ->
case readMaybe (Data.Text.unpack str) of
Nothing -> Err ("Could not parse as boolean: " ++ str)
Just x -> Ok x
uri :: Parser Text.URI.URI
uri =
Parser <| \str ->
case Text.URI.mkURI str of
Left err ->
["Unexpected exception parsing uri:", str, ". Error reads:", Debug.toString err]
|> Data.Text.unwords
|> Err
Right x -> Ok x
filePath :: Parser FilePath
filePath = Parser (Ok << Data.Text.unpack)
secret :: Parser a -> Parser (Log.Secret a)
secret = map Log.mkSecret
networkURI :: Parser Network.URI.URI
networkURI =
Parser <| \str ->
case Network.URI.parseURI (Data.Text.unpack str) of
Nothing -> Err "Oh no! We have a valid Network.URI.URI but can't seem to parse it as a Network.URI.URI."
Just uri' -> Ok uri' {Network.URI.uriPath = ""}
custom :: Parser a -> (a -> Result Text b) -> Parser b
custom (Parser base) fn = Parser (\val -> base val |> andThen fn)
data Decoder config
= Decoder
{
consumes :: [Variable],
readFromEnvironment :: Dict.Dict Text Text -> Result [ParseError] config
}
deriving (Functor)
instance Applicative Decoder where
pure x = Decoder [] (\_ -> Ok x)
(Decoder consumes1 f) <*> (Decoder consumes2 x) =
Decoder
{ consumes = consumes1 ++ consumes2,
readFromEnvironment = readFromEnvironment' f x
}
where
readFromEnvironment' ::
Semigroup err =>
(env -> Result err (a -> config)) ->
(env -> Result err a) ->
env ->
Result err config
readFromEnvironment' f' x' env =
case (f' env, x' env) of
(Err fe, Err xe) ->
Err (fe ++ xe)
(fr, xr) ->
fr <*> xr
data Variable
= Variable
{ name :: Text,
description :: Text,
defaultValue :: Text
}
deriving (Show)
data ParseError
= ParseError
{ failingVariable :: Variable,
failingReason :: Text
}
deriving (Show)
data DecodedVariable
= DecodedVariable
{ decodedVariable :: Variable,
decodedCurrent :: Maybe Text,
decodedErrors :: List Text
}
deriving (Show)
variable :: Variable -> Parser a -> Decoder a
variable var (Parser parse) =
Decoder
{ consumes = [var],
readFromEnvironment = \env ->
let value =
Dict.get (name var) env
|> Maybe.withDefault (defaultValue var)
in parse value |> Result.mapError (pure << ParseError var)
}
either :: Decoder a -> Decoder a -> Decoder a
either (Decoder consumes1 fa) (Decoder consumes2 fb) =
Decoder
{ consumes = consumes1 ++ consumes2,
readFromEnvironment = \env ->
case fa env of
Err ea -> case fb env of
Err eb -> Err (ea ++ eb)
Ok r -> Ok r
Ok r -> Ok r
}
decode :: Decoder a -> IO a
decode configuration = do
env <- getEnv
case decodePairs configuration env of
Err err -> fail (Data.Text.unpack err)
Ok x -> pure x
decodePairs :: Decoder a -> Dict.Dict Text Text -> Result Text a
decodePairs configuration env =
case readFromEnvironment configuration env of
Err err -> Err (errorsToText err)
Ok x -> Ok x
decodeVariables :: Decoder a -> IO [DecodedVariable]
decodeVariables configuration =
fmap (decodeVariablePairs configuration) getEnv
decodeVariablePairs :: Decoder a -> Dict.Dict Text Text -> [DecodedVariable]
decodeVariablePairs configuration env = do
var <- consumes configuration
pure
( DecodedVariable
{ decodedVariable = var,
decodedCurrent = Dict.get (name var) env,
decodedErrors =
Dict.get (name var) errors
|> Maybe.withDefault []
}
)
where
errors =
map errorPair parseErrors
|> List.foldl insert Dict.empty
insert (k, v) dict =
Dict.update
k
( \prev ->
case prev of
Nothing -> Just v
Just v' -> Just (v' ++ v)
)
dict
errorPair err =
((failingVariable >> name) err, [failingReason err])
parseErrors =
case readFromEnvironment configuration env of
Err errs -> errs
Ok _ -> []
getEnv :: IO (Dict.Dict Text Text)
getEnv = do
pairs <- System.Environment.getEnvironment
pure <| Dict.fromList <| map (Tuple.mapBoth Data.Text.pack Data.Text.pack) pairs
decodeDefaults :: Decoder a -> Result Text a
decodeDefaults configuration =
readFromEnvironment configuration mempty |> Result.mapError errorsToText
errorsToText :: [ParseError] -> Text
errorsToText errors = map errorToText errors |> Data.Text.intercalate "\n\n"
errorToText :: ParseError -> Text
errorToText ParseError {failingVariable, failingReason} =
Data.Text.unwords ["Parsing", name failingVariable, "failed:", failingReason]