{-# LANGUAGE CPP #-}

-- | Parse the shell environment for configuration
--
-- A minor extension of [envparse](https://hackage.haskell.org/package/envparse).
--
-- Usage:
--
-- > import Freckle.App.Env
-- >
-- > data Config = Config -- Example
-- >   { cBatchSize :: Natural
-- >   , cDryRun :: Bool
-- >   , cLogLevel :: LogLevel
-- >   }
-- >
-- > loadConfig :: IO Config
-- > loadConfig = parse $ Config
-- >   <$> var auto "BATCH_SIZE" (def 1)
-- >   <*> switch "DRY_RUN" mempty
-- >   <*> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty
--
module Freckle.App.Env
  ( module Env

  -- * Replacements
  , Off(..)
  , On(..)
  , flag

  -- * Extensions
  , kept
  , eitherReader
  , time
  , keyValues
  ) where

import Freckle.App.Prelude

import Control.Error.Util (note)
import qualified Data.Text as T
import Data.Time (defaultTimeLocale, parseTimeM)
import Env hiding (flag)
import qualified Env
import Env.Internal.Free (hoistAlt)
import Env.Internal.Parser (Parser(..), VarF(..))

-- | Designates the value of a parameter when a flag is not provided.
newtype Off a = Off a

-- | Designates the value of a parameter when a flag is provided.
newtype On a = On a

-- | Parse a simple flag
--
-- If the variable is present and non-empty in the environment, the active value
-- is returned, otherwise the default is used.
--
-- >>> import Blammo.Logging (LogLevel(..))
--
-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "1")]
-- Right LevelDebug
--
-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "")]
-- Right LevelInfo
--
-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` []
-- Right LevelInfo
--
-- N.B. only the empty string is falsey:
--
-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "false")]
-- Right LevelDebug
--
-- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "no")]
-- Right LevelDebug
--
flag :: Off a -> On a -> String -> Mod Flag a -> Parser Error a
flag :: forall a. Off a -> On a -> String -> Mod Flag a -> Parser Error a
flag (Off a
f) (On a
t) String
n Mod Flag a
m = forall a e. a -> a -> String -> Mod Flag a -> Parser e a
Env.flag a
f a
t String
n Mod Flag a
m

-- | Modify a 'Parser' so variables are never removed after reading
--
-- In @envparse-0.4@, read variables are removed from the environment by
-- default. This is often problematic (e.g. in tests that repeatedly load an app
-- and re-read the environment), and the security benefits are minor. This
-- function will make them all behave as if @keep@ was used.
--
-- In @envparse-0.5@, the default is reversed and @sensitive@ can be used to
-- explicitly unset read variables, and so this function will instead make them
-- all behave as if @sensitive@ was /not/ used.
--
kept :: Parser e a -> Parser e a
kept :: forall e a. Parser e a -> Parser e a
kept = forall e a. Alt (VarF e) a -> Parser e a
Parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (g :: * -> *) b.
Functor g =>
(forall a. f a -> g a) -> Alt f b -> Alt g b
hoistAlt forall {e} {a}. VarF e a -> VarF e a
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Parser e a -> Alt (VarF e) a
unParser
 where
  go :: VarF e a -> VarF e a
go VarF e a
v =
#if MIN_VERSION_envparse(0,5,0)
    VarF e a
v { varfSensitive :: Bool
varfSensitive = Bool
False }
#else
    v { varfKeep = True }
#endif

-- | Create a 'Reader' from a simple parser function
--
-- This is a building-block for other 'Reader's
--
eitherReader :: (String -> Either String a) -> Reader Error a
eitherReader :: forall a. (String -> Either String a) -> Reader Error a
eitherReader String -> Either String a
f String
s = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall e. AsUnread e => String -> e
unread forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
suffix) forall a b. (a -> b) -> a -> b
$ String -> Either String a
f String
s
  where suffix :: String -> String
suffix String
x = String
x forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
s

-- | Read a time value using the given format
--
-- >>> var (time "%Y-%m-%d") "TIME" mempty `parsePure` [("TIME", "1985-02-12")]
-- Right 1985-02-12 00:00:00 UTC
--
-- >>> var (time "%Y-%m-%d") "TIME" mempty `parsePure` [("TIME", "10:00PM")]
-- Left [("TIME",UnreadError "unable to parse time as %Y-%m-%d: \"10:00PM\"")]
--
time :: String -> Reader Error UTCTime
time :: String -> Reader Error UTCTime
time String
fmt =
  forall a. (String -> Either String a) -> Reader Error a
eitherReader
    forall a b. (a -> b) -> a -> b
$ forall a b. a -> Maybe b -> Either a b
note (String
"unable to parse time as " forall a. Semigroup a => a -> a -> a
<> String
fmt)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt

-- | Read key-value pairs
--
-- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo:bar,baz:bat")]
-- Right [("foo","bar"),("baz","bat")]
--
-- Value-less keys are not supported:
--
-- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo,baz:bat")]
-- Left [("TAGS",UnreadError "Key foo has no value: \"foo,baz:bat\"")]
--
-- Nor are key-less values:
--
-- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo:bar,:bat")]
-- Left [("TAGS",UnreadError "Value bat has no key: \"foo:bar,:bat\"")]
--
keyValues :: Reader Error [(Text, Text)]
keyValues :: Reader Error [(Text, Text)]
keyValues = forall a. (String -> Either String a) -> Reader Error a
eitherReader forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either String (Text, Text)
keyValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
 where
  keyValue :: Text -> Either String (Text, Text)
  keyValue :: Text -> Either String (Text, Text)
keyValue Text
t = case forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Text -> Text
T.drop Int
1) forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOn Text
":" Text
t of
    (Text
k, Text
v) | Text -> Bool
T.null Text
v -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Key " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
k forall a. Semigroup a => a -> a -> a
<> String
" has no value"
    (Text
k, Text
v) | Text -> Bool
T.null Text
k -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Value " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
v forall a. Semigroup a => a -> a -> a
<> String
" has no key"
    (Text
k, Text
v) -> forall a b. b -> Either a b
Right (Text
k, Text
v)