module Mensam.Server.Application.Environment.Acquisition where

import Mensam.Server.Environment

import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Elevator
import Control.Monad.Trans.State
import Data.List qualified as L
import Data.Proxy
import Data.Text qualified as T
import GHC.TypeLits
import System.Posix.Env qualified as System

acquireEnvironment ::
  (MonadIO m, MonadLogger m) =>
  m Environment
acquireEnvironment :: forall (m :: * -> *). (MonadIO m, MonadLogger m) => m Environment
acquireEnvironment = do
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Looking up environment variables."
  [(String, String)]
env <- IO [(String, String)] -> m [(String, String)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
System.getEnvironment
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Looked up environment variables: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([(String, String)] -> String
forall a. Show a => a -> String
show [(String, String)]
env)

  (Environment
environment, [(String, String)]
unconsumedEnv) <- (StateT [(String, String)] m Environment
 -> [(String, String)] -> m (Environment, [(String, String)]))
-> [(String, String)]
-> StateT [(String, String)] m Environment
-> m (Environment, [(String, String)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [(String, String)] m Environment
-> [(String, String)] -> m (Environment, [(String, String)])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT [(String, String)]
env (StateT [(String, String)] m Environment
 -> m (Environment, [(String, String)]))
-> (Elevator (StateT [(String, String)]) m Environment
    -> StateT [(String, String)] m Environment)
-> Elevator (StateT [(String, String)]) m Environment
-> m (Environment, [(String, String)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Elevator (StateT [(String, String)]) m Environment
-> StateT [(String, String)] m Environment
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Elevator t m a -> t m a
descend (Elevator (StateT [(String, String)]) m Environment
 -> m (Environment, [(String, String)]))
-> Elevator (StateT [(String, String)]) m Environment
-> m (Environment, [(String, String)])
forall a b. (a -> b) -> a -> b
$ do
    Const String 'EnvVarConfigFile
configFile <- SEnvVar 'EnvVarConfigFile
-> Elevator
     (StateT [(String, String)])
     m
     (Const (EnvVarValue 'EnvVarConfigFile) 'EnvVarConfigFile)
forall (envVar :: EnvVar) (m :: * -> *).
(KnownSymbol (EnvVarName envVar), MonadLogger m,
 Show (EnvVarValue envVar)) =>
SEnvVar envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
lookupEnvironmentVariable SEnvVar 'EnvVarConfigFile
SEnvVarConfigFile
    Const Bool 'EnvVarLogColor
logColor <- SEnvVar 'EnvVarLogColor
-> Elevator
     (StateT [(String, String)])
     m
     (Const (EnvVarValue 'EnvVarLogColor) 'EnvVarLogColor)
forall (envVar :: EnvVar) (m :: * -> *).
(KnownSymbol (EnvVarName envVar), MonadLogger m,
 Show (EnvVarValue envVar)) =>
SEnvVar envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
lookupEnvironmentVariable SEnvVar 'EnvVarLogColor
SEnvVarLogColor
    Const (Maybe String) 'EnvVarLogFile
logFile <- SEnvVar 'EnvVarLogFile
-> Elevator
     (StateT [(String, String)])
     m
     (Const (EnvVarValue 'EnvVarLogFile) 'EnvVarLogFile)
forall (envVar :: EnvVar) (m :: * -> *).
(KnownSymbol (EnvVarName envVar), MonadLogger m,
 Show (EnvVarValue envVar)) =>
SEnvVar envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
lookupEnvironmentVariable SEnvVar 'EnvVarLogFile
SEnvVarLogFile
    Const LogLevel 'EnvVarLogLevel
logLevel <- SEnvVar 'EnvVarLogLevel
-> Elevator
     (StateT [(String, String)])
     m
     (Const (EnvVarValue 'EnvVarLogLevel) 'EnvVarLogLevel)
forall (envVar :: EnvVar) (m :: * -> *).
(KnownSymbol (EnvVarName envVar), MonadLogger m,
 Show (EnvVarValue envVar)) =>
SEnvVar envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
lookupEnvironmentVariable SEnvVar 'EnvVarLogLevel
SEnvVarLogLevel

    let
      environment :: SEnvVar envVar -> Const (EnvVarValue envVar) envVar
      environment :: forall (envVar :: EnvVar).
SEnvVar envVar -> Const (EnvVarValue envVar) envVar
environment = \case
        SEnvVar envVar
SEnvVarConfigFile -> Const String 'EnvVarConfigFile
Const (EnvVarValue envVar) envVar
configFile
        SEnvVar envVar
SEnvVarLogColor -> Const Bool 'EnvVarLogColor
Const (EnvVarValue envVar) envVar
logColor
        SEnvVar envVar
SEnvVarLogFile -> Const (Maybe String) 'EnvVarLogFile
Const (EnvVarValue envVar) envVar
logFile
        SEnvVar envVar
SEnvVarLogLevel -> Const LogLevel 'EnvVarLogLevel
Const (EnvVarValue envVar) envVar
logLevel

    Environment -> Elevator (StateT [(String, String)]) m Environment
forall a. a -> Elevator (StateT [(String, String)]) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Environment -> Elevator (StateT [(String, String)]) m Environment)
-> Environment
-> Elevator (StateT [(String, String)]) m Environment
forall a b. (a -> b) -> a -> b
$ (forall (envVar :: EnvVar). SEnvVar envVar -> EnvVarValue envVar)
-> Environment
MkEnvironment ((forall (envVar :: EnvVar). SEnvVar envVar -> EnvVarValue envVar)
 -> Environment)
-> (forall (envVar :: EnvVar).
    SEnvVar envVar -> EnvVarValue envVar)
-> Environment
forall a b. (a -> b) -> a -> b
$ Const (EnvVarValue envVar) envVar -> EnvVarValue envVar
forall {k} a (b :: k). Const a b -> a
getConst (Const (EnvVarValue envVar) envVar -> EnvVarValue envVar)
-> (SEnvVar envVar -> Const (EnvVarValue envVar) envVar)
-> SEnvVar envVar
-> EnvVarValue envVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SEnvVar envVar -> Const (EnvVarValue envVar) envVar
forall (envVar :: EnvVar).
SEnvVar envVar -> Const (EnvVarValue envVar) envVar
environment

  [(String, String)] -> m ()
forall (m :: * -> *). MonadLogger m => [(String, String)] -> m ()
checkUnconsumedEnvironment [(String, String)]
unconsumedEnv
  Environment -> m Environment
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Environment
environment

lookupEnvironmentVariable ::
  forall envVar m.
  (KnownSymbol (EnvVarName envVar), MonadLogger m, Show (EnvVarValue envVar)) =>
  SEnvVar envVar ->
  Elevator (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
lookupEnvironmentVariable :: forall (envVar :: EnvVar) (m :: * -> *).
(KnownSymbol (EnvVarName envVar), MonadLogger m,
 Show (EnvVarValue envVar)) =>
SEnvVar envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
lookupEnvironmentVariable SEnvVar envVar
singEnvVar = do
  Text -> Elevator (StateT [(String, String)]) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> Elevator (StateT [(String, String)]) m ())
-> Text -> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Inspecting environment variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
envVarName)
  [(String, String)]
env <- StateT [(String, String)] m [(String, String)]
-> Elevator (StateT [(String, String)]) m [(String, String)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> Elevator t m a
Ascend StateT [(String, String)] m [(String, String)]
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
envVarName [(String, String)]
env of
    Maybe String
Nothing -> do
      Text -> Elevator (StateT [(String, String)]) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> Elevator (StateT [(String, String)]) m ())
-> Text -> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Environment variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
envVarName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is not set."
      Text -> Elevator (StateT [(String, String)]) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> Elevator (StateT [(String, String)]) m ())
-> Text -> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Using default value for environment variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
envVarName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"': " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (EnvVarValue envVar -> String
forall a. Show a => a -> String
show EnvVarValue envVar
envVarDefaultValue)
      Const (EnvVarValue envVar) envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
forall a. a -> Elevator (StateT [(String, String)]) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Const (EnvVarValue envVar) envVar
 -> Elevator
      (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar))
-> Const (EnvVarValue envVar) envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
forall a b. (a -> b) -> a -> b
$ EnvVarValue envVar -> Const (EnvVarValue envVar) envVar
forall {k} a (b :: k). a -> Const a b
Const EnvVarValue envVar
envVarDefaultValue
    Just String
str -> do
      Text -> Elevator (StateT [(String, String)]) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> Elevator (StateT [(String, String)]) m ())
-> Text -> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Spotted environment variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
envVarName)
      StateT [(String, String)] m ()
-> Elevator (StateT [(String, String)]) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> Elevator t m a
Ascend (StateT [(String, String)] m ()
 -> Elevator (StateT [(String, String)]) m ())
-> StateT [(String, String)] m ()
-> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ ([(String, String)] -> [(String, String)])
-> StateT [(String, String)] m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (([(String, String)] -> [(String, String)])
 -> StateT [(String, String)] m ())
-> ([(String, String)] -> [(String, String)])
-> StateT [(String, String)] m ()
forall a b. (a -> b) -> a -> b
$ ((String, String) -> (String, String) -> Bool)
-> (String, String) -> [(String, String)] -> [(String, String)]
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
L.deleteBy (\(String, String)
x (String, String)
y -> (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
y) (String
envVarName, String
forall a. HasCallStack => a
undefined)
      Text -> Elevator (StateT [(String, String)]) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> Elevator (StateT [(String, String)]) m ())
-> Text -> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Parsing environment variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
envVarName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"': " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
str)
      case SEnvVar envVar -> String -> Maybe (EnvVarValue envVar)
forall (envVar :: EnvVar).
SEnvVar envVar -> String -> Maybe (EnvVarValue envVar)
envVarParse SEnvVar envVar
singEnvVar String
str of
        Maybe (EnvVarValue envVar)
Nothing -> do
          Text -> Elevator (StateT [(String, String)]) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError (Text -> Elevator (StateT [(String, String)]) m ())
-> Text -> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse environment variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
envVarName)
          Text -> Elevator (StateT [(String, String)]) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn (Text -> Elevator (StateT [(String, String)]) m ())
-> Text -> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Falling back to default value for environment variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
envVarName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"': " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (EnvVarValue envVar -> String
forall a. Show a => a -> String
show EnvVarValue envVar
envVarDefaultValue)
          Const (EnvVarValue envVar) envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
forall a. a -> Elevator (StateT [(String, String)]) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Const (EnvVarValue envVar) envVar
 -> Elevator
      (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar))
-> Const (EnvVarValue envVar) envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
forall a b. (a -> b) -> a -> b
$ EnvVarValue envVar -> Const (EnvVarValue envVar) envVar
forall {k} a (b :: k). a -> Const a b
Const EnvVarValue envVar
envVarDefaultValue
        Just EnvVarValue envVar
val -> do
          Text -> Elevator (StateT [(String, String)]) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> Elevator (StateT [(String, String)]) m ())
-> Text -> Elevator (StateT [(String, String)]) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Parsed environment variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
forall a. Show a => a -> String
show String
envVarName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"': " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (EnvVarValue envVar -> String
forall a. Show a => a -> String
show EnvVarValue envVar
val)
          Const (EnvVarValue envVar) envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
forall a. a -> Elevator (StateT [(String, String)]) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Const (EnvVarValue envVar) envVar
 -> Elevator
      (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar))
-> Const (EnvVarValue envVar) envVar
-> Elevator
     (StateT [(String, String)]) m (Const (EnvVarValue envVar) envVar)
forall a b. (a -> b) -> a -> b
$ EnvVarValue envVar -> Const (EnvVarValue envVar) envVar
forall {k} a (b :: k). a -> Const a b
Const EnvVarValue envVar
val
 where
  envVarName :: String
envVarName = Proxy (EnvVarName envVar) -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy (EnvVarName envVar) -> String)
-> Proxy (EnvVarName envVar) -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @(EnvVarName envVar)
  envVarDefaultValue :: EnvVarValue envVar
envVarDefaultValue = SEnvVar envVar -> EnvVarValue envVar
forall (envVar :: EnvVar). SEnvVar envVar -> EnvVarValue envVar
envVarDefault SEnvVar envVar
singEnvVar

checkUnconsumedEnvironment ::
  MonadLogger m =>
  [(String, String)] ->
  m ()
checkUnconsumedEnvironment :: forall (m :: * -> *). MonadLogger m => [(String, String)] -> m ()
checkUnconsumedEnvironment [(String, String)]
env = do
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Checking unconsumed environment for left-over environment variables: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([(String, String)] -> String
forall a. Show a => a -> String
show [(String, String)]
env)
  case ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String, String) -> Bool
isSuspicious [(String, String)]
env of
    [] -> Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Unconsumed environment doesn't contain any anomalies."
    [(String, String)]
anomalies -> Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Unconsumed environment contains anomalies: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([(String, String)] -> String
forall a. Show a => a -> String
show [(String, String)]
anomalies)
 where
  isSuspicious :: (String, String) -> Bool
  isSuspicious :: (String, String) -> Bool
isSuspicious (String
identifier, String
_value) = String
"MENSAM" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
identifier