{-# 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
  , Timeout (..)
  , kept
  , eitherReader
  , time
  , keyValues
  , keyValue
  , splitOnParse
  , timeout
  ) where

import Freckle.App.Prelude

import Control.Error.Util (note)
import Data.Char (isDigit)
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 (..))
import qualified Prelude as Unsafe (read)

-- | 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 = a -> a -> String -> Mod Flag a -> Parser Error a
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 = Alt (VarF e) a -> Parser e a
forall e a. Alt (VarF e) a -> Parser e a
Parser (Alt (VarF e) a -> Parser e a)
-> (Parser e a -> Alt (VarF e) a) -> Parser e a -> Parser e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. VarF e a -> VarF e a)
-> Alt (VarF e) a -> Alt (VarF e) a
forall (f :: * -> *) (g :: * -> *) b.
Functor g =>
(forall a. f a -> g a) -> Alt f b -> Alt g b
hoistAlt VarF e a -> VarF e a
forall a. VarF e a -> VarF e a
forall {e} {a}. VarF e a -> VarF e a
go (Alt (VarF e) a -> Alt (VarF e) a)
-> (Parser e a -> Alt (VarF e) a) -> Parser e a -> Alt (VarF e) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser e a -> Alt (VarF e) a
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 = (String -> Error) -> Either String a -> Either Error a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Error
forall e. AsUnread e => String -> e
unread (String -> Error) -> (String -> String) -> String -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
suffix) (Either String a -> Either Error a)
-> Either String a -> Either Error a
forall a b. (a -> b) -> a -> b
$ String -> Either String a
f String
s
 where
  suffix :: String -> String
suffix String
x = String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
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 =
  (String -> Either String UTCTime) -> Reader Error UTCTime
forall a. (String -> Either String a) -> Reader Error a
eitherReader ((String -> Either String UTCTime) -> Reader Error UTCTime)
-> (String -> Either String UTCTime) -> Reader Error UTCTime
forall a b. (a -> b) -> a -> b
$
    String -> Maybe UTCTime -> Either String UTCTime
forall a b. a -> Maybe b -> Either a b
note (String
"unable to parse time as " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fmt)
      (Maybe UTCTime -> Either String UTCTime)
-> (String -> Maybe UTCTime) -> String -> Either String UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> TimeLocale -> String -> String -> Maybe UTCTime
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\"")]
--
-- Nor are key-less values:
--
-- >>> var keyValues "TAGS" mempty `parsePure` [("TAGS", "foo:bar,:bat")]
-- Left [("TAGS",UnreadError "Value bat has no key: \":bat\"")]
keyValues :: Reader Error [(Text, Text)]
keyValues :: Reader Error [(Text, Text)]
keyValues = Char -> Reader Error (Text, Text) -> Reader Error [(Text, Text)]
forall e a. Char -> Reader e a -> Reader e [a]
splitOnParse Char
',' (Reader Error (Text, Text) -> Reader Error [(Text, Text)])
-> Reader Error (Text, Text) -> Reader Error [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Char -> Reader Error (Text, Text)
keyValue Char
':'

keyValue :: Char -> Reader Error (Text, Text)
keyValue :: Char -> Reader Error (Text, Text)
keyValue Char
c =
  (String -> Either String (Text, Text)) -> Reader Error (Text, Text)
forall a. (String -> Either String a) -> Reader Error a
eitherReader ((String -> Either String (Text, Text))
 -> Reader Error (Text, Text))
-> (String -> Either String (Text, Text))
-> Reader Error (Text, Text)
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Either String (Text, Text)
go ((Text, Text) -> Either String (Text, Text))
-> (String -> (Text, Text)) -> String -> Either String (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> (Text, Text) -> (Text, Text)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Text -> Text
T.drop Int
1) ((Text, Text) -> (Text, Text))
-> (String -> (Text, Text)) -> String -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn (Char -> Text
T.singleton Char
c) (Text -> (Text, Text))
-> (String -> Text) -> String -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
 where
  go :: (Text, Text) -> Either String (Text, Text)
go = \case
    (Text
k, Text
v) | Text -> Bool
T.null Text
v -> String -> Either String (Text, Text)
forall a b. a -> Either a b
Left (String -> Either String (Text, Text))
-> String -> Either String (Text, Text)
forall a b. (a -> b) -> a -> b
$ String
"Key " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has no value"
    (Text
k, Text
v) | Text -> Bool
T.null Text
k -> String -> Either String (Text, Text)
forall a b. a -> Either a b
Left (String -> Either String (Text, Text))
-> String -> Either String (Text, Text)
forall a b. (a -> b) -> a -> b
$ String
"Value " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has no key"
    (Text
k, Text
v) -> (Text, Text) -> Either String (Text, Text)
forall a b. b -> Either a b
Right (Text
k, Text
v)

-- | Use 'splitOn' then call the given 'Reader' on each element
--
-- @
-- 'splitOnParse' c pure == 'splitOn' c
-- @
--
-- >>> var (splitOnParse @Error ',' nonempty) "X" mempty `parsePure` [("X", "a,b")]
-- Right ["a","b"]
--
-- >>> var (splitOnParse @Error ',' nonempty) "X" mempty `parsePure` [("X", ",,")]
-- Left [("X",EmptyError)]
--
splitOnParse :: Char -> Reader e a -> Reader e [a]
splitOnParse :: forall e a. Char -> Reader e a -> Reader e [a]
splitOnParse Char
c Reader e a
p = Reader e a -> [String] -> Either e [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Reader e a
p ([String] -> Either e [a])
-> (String -> Either e [String]) -> String -> Either e [a]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Char -> String -> Either e [String]
forall e. Char -> Reader e [String]
splitOn Char
c

-- | Represents a timeout in seconds or milliseconds
data Timeout
  = TimeoutSeconds Int
  | TimeoutMilliseconds Int
  deriving stock (Int -> Timeout -> String -> String
[Timeout] -> String -> String
Timeout -> String
(Int -> Timeout -> String -> String)
-> (Timeout -> String)
-> ([Timeout] -> String -> String)
-> Show Timeout
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Timeout -> String -> String
showsPrec :: Int -> Timeout -> String -> String
$cshow :: Timeout -> String
show :: Timeout -> String
$cshowList :: [Timeout] -> String -> String
showList :: [Timeout] -> String -> String
Show, Timeout -> Timeout -> Bool
(Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool) -> Eq Timeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Timeout -> Timeout -> Bool
== :: Timeout -> Timeout -> Bool
$c/= :: Timeout -> Timeout -> Bool
/= :: Timeout -> Timeout -> Bool
Eq)

-- | Read a timeout value as seconds or milliseconds
--
-- >>> var timeout "TIMEOUT" mempty `parsePure` [("TIMEOUT", "10")]
-- Right (TimeoutSeconds 10)
--
-- >>> var timeout "TIMEOUT" mempty `parsePure` [("TIMEOUT", "10s")]
-- Right (TimeoutSeconds 10)
--
-- >>> var timeout "TIMEOUT" mempty `parsePure` [("TIMEOUT", "10ms")]
-- Right (TimeoutMilliseconds 10)
--
-- >>> var timeout "TIMEOUT" mempty `parsePure` [("TIMEOUT", "20m")]
-- Left [("TIMEOUT",UnreadError "must be {digits}(s|ms): \"20m\"")]
--
-- >>> var timeout "TIMEOUT" mempty `parsePure` [("TIMEOUT", "2m0")]
-- Left [("TIMEOUT",UnreadError "must be {digits}(s|ms): \"2m0\"")]
timeout :: Reader Error Timeout
timeout :: Reader Error Timeout
timeout = (String -> Either String Timeout) -> Reader Error Timeout
forall a. (String -> Either String a) -> Reader Error a
eitherReader ((String -> Either String Timeout) -> Reader Error Timeout)
-> (String -> Either String Timeout) -> Reader Error Timeout
forall a b. (a -> b) -> a -> b
$ (String, String) -> Either String Timeout
forall {a} {a}.
(Eq a, IsString a, IsString a) =>
(String, a) -> Either a Timeout
parseTimeout ((String, String) -> Either String Timeout)
-> (String -> (String, String)) -> String -> Either String Timeout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit
 where
  parseTimeout :: (String, a) -> Either a Timeout
parseTimeout = \case
    (String
"", a
_) -> a -> Either a Timeout
forall a b. a -> Either a b
Left a
"must be {digits}(s|ms)"
    (String
digits, a
"") -> Timeout -> Either a Timeout
forall a b. b -> Either a b
Right (Timeout -> Either a Timeout) -> Timeout -> Either a Timeout
forall a b. (a -> b) -> a -> b
$ Int -> Timeout
TimeoutSeconds (Int -> Timeout) -> Int -> Timeout
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
Unsafe.read String
digits
    (String
digits, a
"s") -> Timeout -> Either a Timeout
forall a b. b -> Either a b
Right (Timeout -> Either a Timeout) -> Timeout -> Either a Timeout
forall a b. (a -> b) -> a -> b
$ Int -> Timeout
TimeoutSeconds (Int -> Timeout) -> Int -> Timeout
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
Unsafe.read String
digits
    (String
digits, a
"ms") ->
      Timeout -> Either a Timeout
forall a b. b -> Either a b
Right (Timeout -> Either a Timeout) -> Timeout -> Either a Timeout
forall a b. (a -> b) -> a -> b
$ Int -> Timeout
TimeoutMilliseconds (Int -> Timeout) -> Int -> Timeout
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
Unsafe.read String
digits
    (String, a)
_ -> a -> Either a Timeout
forall a b. a -> Either a b
Left a
"must be {digits}(s|ms)"