{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module EVP
  ( Name
  , Error(..)
  -- * Parsers
  , string
  , yaml
  , parse
  , secret
  -- * Providing a default value
  , stringDefault
  , yamlDefault
  , parseDefault
  -- * Runner
  , Settings(..)
  , def
  , scan
  , scanWith
  , enumerate
  -- * Logger
  , assumePrefix
  , obsolete
  -- * Internal
  , Scan(..)
  ) where

import Control.Monad
import Data.Bifunctor
import Data.Default.Class
import Data.List (isPrefixOf)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.String
import Data.Yaml qualified as Yaml
import Data.Text.Encoding
import System.Environment
import System.Exit
import System.IO

type Name = String

data Error = Missing Name
  | ParseError Name String
  deriving Int -> Error -> ShowS
[Error] -> ShowS
Error -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> Name
$cshow :: Error -> Name
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show

-- | Obtain the environment variable.
string :: (IsString a) => Name -> Scan a
string :: forall a. IsString a => Name -> Scan a
string Name
v = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (\case
  Maybe Name
Nothing -> forall a b. a -> Either a b
Left (Name -> Error
Missing Name
v)
  Just Name
x -> forall a b. b -> Either a b
Right (Name
x, forall a. IsString a => Name -> a
fromString Name
x)) (forall a. a -> Scan a
Pure forall a. a -> a
id)

stringDefault :: (IsString a) => Name -> String -> Scan a
stringDefault :: forall a. IsString a => Name -> Name -> Scan a
stringDefault Name
v Name
d = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (\case
  Maybe Name
Nothing -> forall a b. b -> Either a b
Right (Name
d forall a. Semigroup a => a -> a -> a
<> Name
" (default)", forall a. IsString a => Name -> a
fromString Name
d)
  Just Name
x -> forall a b. b -> Either a b
Right (Name
x, forall a. IsString a => Name -> a
fromString Name
x)) (forall a. a -> Scan a
Pure forall a. a -> a
id)

-- | Parse the environment variable as a YAML value.
yaml :: (Show a, Yaml.FromJSON a) => Name -> Scan a
yaml :: forall a. (Show a, FromJSON a) => Name -> Scan a
yaml Name
v = forall a. Show a => Name -> (Name -> Either Name a) -> Scan a
parse Name
v forall a. FromJSON a => Name -> Either Name a
decodeYaml

-- | Parse the environment variable as a YAML value.
yamlDefault :: (Show a, Yaml.FromJSON a) => Name -> a -> Scan a
yamlDefault :: forall a. (Show a, FromJSON a) => Name -> a -> Scan a
yamlDefault Name
v a
d = forall a. Show a => Name -> a -> (Name -> Either Name a) -> Scan a
parseDefault Name
v a
d forall a. FromJSON a => Name -> Either Name a
decodeYaml

decodeYaml :: Yaml.FromJSON a => String -> Either String a
decodeYaml :: forall a. FromJSON a => Name -> Either Name a
decodeYaml = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> Name
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => Name -> a
fromString

parse :: (Show a) => Name -> (String -> Either String a) -> Scan a
parse :: forall a. Show a => Name -> (Name -> Either Name a) -> Scan a
parse Name
v Name -> Either Name a
f = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (\case
  Maybe Name
Nothing -> forall a b. a -> Either a b
Left (Name -> Error
Missing Name
v)
  Just Name
x -> forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Name -> Name -> Error
ParseError Name
v) forall a. Show a => a -> (Name, a)
withShow forall a b. (a -> b) -> a -> b
$ Name -> Either Name a
f Name
x) (forall a. a -> Scan a
Pure forall a. a -> a
id)

parseDefault :: (Show a) => Name -> a -> (String -> Either String a) -> Scan a
parseDefault :: forall a. Show a => Name -> a -> (Name -> Either Name a) -> Scan a
parseDefault Name
v a
d Name -> Either Name a
f = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (\case
  Maybe Name
Nothing -> forall a b. b -> Either a b
Right (forall a. Show a => a -> Name
show a
d forall a. Semigroup a => a -> a -> a
<> Name
" (default)", a
d)
  Just Name
x -> forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Name -> Name -> Error
ParseError Name
v) forall a. Show a => a -> (Name, a)
withShow forall a b. (a -> b) -> a -> b
$ Name -> Either Name a
f Name
x) (forall a. a -> Scan a
Pure forall a. a -> a
id)

-- | Disable logging of parsed values.
secret :: Scan a -> Scan a
secret :: forall a. Scan a -> Scan a
secret (Pure a
a) = forall a. a -> Scan a
Pure a
a
secret (Var Name
v Maybe Name -> Either Error (Name, a)
f Scan (a -> a)
k) = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. a -> b -> a
const Name
"<REDACTED>")) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Name -> Either Error (Name, a)
f) (forall a. Scan a -> Scan a
secret Scan (a -> a)
k)

withShow :: Show a => a -> (String, a)
withShow :: forall a. Show a => a -> (Name, a)
withShow a
x = (forall a. Show a => a -> Name
show a
x, a
x)
  
data Scan a where
  Pure :: a -> Scan a
  Var :: Name -> (Maybe String -> Either Error (String, a)) -> Scan (a -> b) -> Scan b

instance Functor Scan where
  fmap :: forall a b. (a -> b) -> Scan a -> Scan b
fmap a -> b
f (Pure a
a) = forall a. a -> Scan a
Pure (a -> b
f a
a)
  fmap a -> b
f (Var Name
k Maybe Name -> Either Error (Name, a)
g Scan (a -> a)
c) = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
k Maybe Name -> Either Error (Name, a)
g (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f.) Scan (a -> a)
c)

instance Applicative Scan where
  pure :: forall a. a -> Scan a
pure = forall a. a -> Scan a
Pure
  Pure a -> b
f <*> :: forall a b. Scan (a -> b) -> Scan a -> Scan b
<*> Scan a
k = a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scan a
k
  Var Name
k Maybe Name -> Either Error (Name, a)
f Scan (a -> a -> b)
c <*> Scan a
r = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
k Maybe Name -> Either Error (Name, a)
f (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scan (a -> a -> b)
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scan a
r)
   
type EnvMap = Map.Map String String

data Settings = Settings
  { Settings -> Name -> Name -> IO ()
parseLogger :: Name -> String -> IO ()
  , Settings -> Error -> IO ()
errorLogger :: Error -> IO ()
  , Settings -> Name -> Maybe (IO ())
unusedLogger :: Name -> Maybe (IO ())
  , Settings -> Bool
pedantic :: Bool -- ^ exit on warning
  }
  
instance Default Settings where
  def :: Settings
def = Settings
    { parseLogger :: Name -> Name -> IO ()
parseLogger = \Name
name Name
value -> Name -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Name] -> Name
unwords [Name
"[EVP Info]", Name
name forall a. Semigroup a => a -> a -> a
<> Name
":", Name
value]
    , errorLogger :: Error -> IO ()
errorLogger = \Error
e -> Handle -> Name -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Name] -> Name
unwords [Name
"[EVP Error]", forall a. Show a => a -> Name
show Error
e]
    , unusedLogger :: Name -> Maybe (IO ())
unusedLogger = forall a. Monoid a => a
mempty
    , pedantic :: Bool
pedantic = Bool
False
    }

-- | Custom logging function for 'unusedLogger'.
-- @'assumePrefix' p@ prints a warning for each unused environment variable prefixed by @p@.
assumePrefix :: String -> Name -> Maybe (IO ())
assumePrefix :: Name -> Name -> Maybe (IO ())
assumePrefix Name
prefix Name
name
  | forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf Name
prefix Name
name = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Handle -> Name -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Name] -> Name
unwords [Name
"[EVP Warn]", Name
name, Name
"is set but not used"]
  | Bool
otherwise = forall a. Maybe a
Nothing

-- | @'obsolete' names@ prints a warning if any of the @names@ is set but not used.
obsolete :: [Name] -> Name -> Maybe (IO ())
obsolete :: [Name] -> Name -> Maybe (IO ())
obsolete [Name]
nameSet Name
name
  | forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
name [Name]
nameSet = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Handle -> Name -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Name] -> Name
unwords [Name
"[EVP Warn]", Name
name, Name
"is obsolete"]
  | Bool
otherwise = forall a. Maybe a
Nothing

-- | Enumerate the names of the variables it would parse.
enumerate :: Scan a -> [Name]
enumerate :: forall a. Scan a -> [Name]
enumerate Scan a
m = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Set Name -> Scan a -> Set Name
go forall a. Set a
Set.empty Scan a
m where
  go :: Set.Set Name -> Scan a -> Set.Set Name
  go :: forall a. Set Name -> Scan a -> Set Name
go !Set Name
s (Pure a
_) = Set Name
s
  go !Set Name
s (Var Name
k Maybe Name -> Either Error (Name, a)
_ Scan (a -> a)
cont) = forall a. Set Name -> Scan a -> Set Name
go (forall a. Ord a => a -> Set a -> Set a
Set.insert Name
k Set Name
s) Scan (a -> a)
cont

scan :: Scan a -> IO a
scan :: forall a. Scan a -> IO a
scan = forall a. Settings -> Scan a -> IO a
scanWith forall a. Default a => a
def

scanWith :: Settings -> Scan a -> IO a
scanWith :: forall a. Settings -> Scan a -> IO a
scanWith Settings{Bool
Name -> Maybe (IO ())
Name -> Name -> IO ()
Error -> IO ()
pedantic :: Bool
unusedLogger :: Name -> Maybe (IO ())
errorLogger :: Error -> IO ()
parseLogger :: Name -> Name -> IO ()
pedantic :: Settings -> Bool
unusedLogger :: Settings -> Name -> Maybe (IO ())
errorLogger :: Settings -> Error -> IO ()
parseLogger :: Settings -> Name -> Name -> IO ()
..} Scan a
action = do
  Map Name Name
envs0 <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(Name, Name)]
getEnvironment
  (Map Name Name
remainder, [Error]
errors, Maybe a
result) <- forall a.
Map Name Name
-> Map Name Name -> Scan a -> IO (Map Name Name, [Error], Maybe a)
go Map Name Name
envs0 Map Name Name
envs0 Scan a
action
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Error -> IO ()
errorLogger [Error]
errors
  case forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Name -> Maybe (IO ())
unusedLogger forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map Name Name
remainder of
    Maybe (IO ())
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just IO ()
m -> do
      IO ()
m
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pedantic forall a. IO a
exitFailure
  case Maybe a
result of
    Maybe a
Nothing -> forall a. IO a
exitFailure
    Just a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  where
    go :: EnvMap -> EnvMap -> Scan a -> IO (EnvMap, [Error], Maybe a)
    go :: forall a.
Map Name Name
-> Map Name Name -> Scan a -> IO (Map Name Name, [Error], Maybe a)
go Map Name Name
_ Map Name Name
envs (Pure a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Name Name
envs, [], forall a. a -> Maybe a
Just a
a)
    go Map Name Name
allEnvs Map Name Name
envs (Var Name
name Maybe Name -> Either Error (Name, a)
parser Scan (a -> a)
cont) = case Maybe Name -> Either Error (Name, a)
parser (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name Name
allEnvs) of
      Left Error
e -> do
        (Map Name Name
remainder, [Error]
errors, Maybe (a -> a)
_) <- forall a.
Map Name Name
-> Map Name Name -> Scan a -> IO (Map Name Name, [Error], Maybe a)
go Map Name Name
allEnvs (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
name Map Name Name
envs) Scan (a -> a)
cont
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Name Name
remainder, Error
e forall a. a -> [a] -> [a]
: [Error]
errors, forall a. Maybe a
Nothing)
      Right (Name
display, a
v) -> do
        Name -> Name -> IO ()
parseLogger Name
name Name
display
        (Map Name Name
remainder, [Error]
errors, Maybe (a -> a)
func) <- forall a.
Map Name Name
-> Map Name Name -> Scan a -> IO (Map Name Name, [Error], Maybe a)
go Map Name Name
allEnvs (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
name Map Name Name
envs)  Scan (a -> a)
cont
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Name Name
remainder, [Error]
errors, (forall a b. (a -> b) -> a -> b
$ a
v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (a -> a)
func)