{-# LANGUAGE ConstraintKinds #-}
module IHP.FrameworkConfig
( -- * Re-exports from IHP.FrameworkConfig.Types
  module IHP.FrameworkConfig.Types
  -- * Configuration helpers
, option
, addInitializer
, findOption
, findOptionOrNothing
, ihpDefaultConfig
, buildFrameworkConfig
, defaultIHPSessionCookie
, RootApplication (..)
, defaultPort
, defaultDatabaseUrl
, defaultLoggerForEnv
, isEnvironment
, isDevelopment
, isProduction
, defaultCorsResourcePolicy
, withFrameworkConfig
, configIO
, ExceptionWithCallStack (..)
) where

import IHP.Prelude
import IHP.FrameworkConfig.Types
import qualified System.Directory.OsPath as Directory
import IHP.Environment
import System.OsPath (decodeUtf)
import qualified Data.Text as Text
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Web.Cookie as Cookie
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.TMap as TMap
import qualified Data.Typeable as Typeable
import IHP.View.Types
import IHP.View.CSSFramework.Bootstrap (bootstrap)
import IHP.Log.Types
import IHP.Log (makeRequestLogger, defaultRequestLogger)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Middleware.Cors as Cors
import qualified Network.Wai.Parse as WaiParse
import qualified Control.Exception as Exception
import IHP.EnvVar

import qualified Prelude
import qualified GHC.Stack as Stack


-- | Puts an option into the current configuration
--
-- In case an option already exists with the same type, it will not be overriden:
--
-- > option Production
-- > option Development
-- > findOption @Environment
--
-- This code will return 'Production' as the second call to 'option' is ignored to not override the existing option.
option :: forall option. Typeable option => option -> State.StateT TMap.TMap IO ()
option :: forall option. Typeable option => option -> StateT TMap IO ()
option !option
value = (TMap -> TMap) -> StateT TMap IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\TMap
map -> if forall a. Typeable a => TMap -> Bool
TMap.member @option TMap
map then TMap
map else option -> TMap -> TMap
forall a. Typeable a => a -> TMap -> TMap
TMap.insert option
value TMap
map)
{-# INLINABLE option #-}

-- | Adds a callback to be run during startup of the app server
--
-- The follwoing example will print a hello world message on startup:
--
-- > config = do
-- >     addInitializer (putStrLn "Hello World!")
--
addInitializer :: ((?context :: FrameworkConfig, ?modelContext :: ModelContext) => IO ()) -> State.StateT TMap.TMap IO ()
addInitializer :: ((?context::FrameworkConfig, ?modelContext::ModelContext) => IO ())
-> StateT TMap IO ()
addInitializer (?context::FrameworkConfig, ?modelContext::ModelContext) => IO ()
onStartup = do
    initializers <- [Initializer] -> Maybe [Initializer] -> [Initializer]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Initializer] -> [Initializer])
-> StateT TMap IO (Maybe [Initializer])
-> StateT TMap IO [Initializer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall option. Typeable option => StateT TMap IO (Maybe option)
findOptionOrNothing @[Initializer]
    let newInitializers = [Initializer]
initializers [Initializer] -> [Initializer] -> [Initializer]
forall a. Semigroup a => a -> a -> a
<> [Initializer { IO ()
(?context::FrameworkConfig, ?modelContext::ModelContext) => IO ()
onStartup :: (?context::FrameworkConfig, ?modelContext::ModelContext) => IO ()
onStartup :: (?context::FrameworkConfig, ?modelContext::ModelContext) => IO ()
onStartup }]
    State.modify (\TMap
map -> TMap
map
            TMap -> (TMap -> TMap) -> TMap
forall a b. a -> (a -> b) -> b
|> forall a. Typeable a => TMap -> TMap
TMap.delete @[Initializer]
            TMap -> (TMap -> TMap) -> TMap
forall a b. a -> (a -> b) -> b
|> [Initializer] -> TMap -> TMap
forall a. Typeable a => a -> TMap -> TMap
TMap.insert [Initializer]
newInitializers
        )

ihpDefaultConfig :: ConfigBuilder
ihpDefaultConfig :: StateT TMap IO ()
ihpDefaultConfig = do
    ihpEnv <- ByteString -> Environment -> StateT TMap IO Environment
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
"IHP_ENV" Environment
Development
    option ihpEnv

    option $ AppHostname "localhost"

    port :: AppPort <- envOrDefault "PORT" (AppPort defaultPort)
    option port

    option $ ExceptionTracker Warp.defaultOnException

    environment <- findOption @Environment

    defaultLogger <- configIO (defaultLoggerForEnv environment)
    option defaultLogger
    logger <- findOption @Logger

    requestLoggerIpAddrSource <- envOrDefault "IHP_REQUEST_LOGGER_IP_ADDR_SOURCE" RequestLogger.FromSocket

    reqLoggerMiddleware <- configIO $
            case environment of
                Environment
Development -> do
                                    reqLogger <- (Logger
logger Logger -> (Logger -> IO Middleware) -> IO Middleware
forall a b. a -> (a -> b) -> b
|> Logger -> IO Middleware
defaultRequestLogger)
                                    pure (RequestLoggerMiddleware reqLogger)
                Environment
Production  ->  do
                                    reqLogger <- (Logger
logger Logger -> (Logger -> IO Middleware) -> IO Middleware
forall a b. a -> (a -> b) -> b
|> RequestLoggerSettings -> Logger -> IO Middleware
makeRequestLogger RequestLoggerSettings
forall a. Default a => a
def { RequestLogger.outputFormat = RequestLogger.Apache requestLoggerIpAddrSource })
                                    pure (RequestLoggerMiddleware reqLogger)


    option $ reqLoggerMiddleware

    option $ defaultCorsResourcePolicy

    databaseUrl <- configIO defaultDatabaseUrl

    option $ DatabaseUrl databaseUrl
    (AppPort port) <- findOption @AppPort

    -- The IHP_BASEURL env var can override the hardcoded base url in Config.hs
    ihpBaseUrlEnvVar <- envOrNothing "IHP_BASEURL"
    case ihpBaseUrlEnvVar of
        Just Text
baseUrl -> BaseUrl -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (Text -> BaseUrl
BaseUrl Text
baseUrl)
        Maybe Text
Nothing -> do
            (AppHostname appHostname) <- forall option. Typeable option => StateT TMap IO option
findOption @AppHostname
            option $ BaseUrl ("http://" <> appHostname <> (if port /= 80 then ":" <> tshow port else ""))

    (BaseUrl currentBaseUrl) <- findOption @BaseUrl
    option $ SessionCookie (defaultIHPSessionCookie currentBaseUrl)

    option WaiParse.defaultParseRequestBodyOptions

    option bootstrap

    when (environment == Development) do
        ihpIdeBaseUrl <- envOrDefault "IHP_IDE_BASEURL" ("http://localhost:" <> tshow (port + 1))
        option (IdeBaseUrl ihpIdeBaseUrl)

    rlsAuthenticatedRole <- envOrDefault "IHP_RLS_AUTHENTICATED_ROLE" "ihp_authenticated"
    option $ RLSAuthenticatedRole rlsAuthenticatedRole

    dataSyncMaxSubscriptionsPerConnection <- envOrDefault "IHP_DATASYNC_MAX_SUBSCRIPTIONS_PER_CONNECTION" 128
    dataSyncMaxTransactionsPerConnection <- envOrDefault "IHP_DATASYNC_MAX_TRANSACTIONS_PER_CONNECTION" 10
    option $ DataSyncMaxSubscriptionsPerConnection dataSyncMaxSubscriptionsPerConnection
    option $ DataSyncMaxTransactionsPerConnection dataSyncMaxTransactionsPerConnection

    option $ CustomMiddleware id

{-# INLINABLE ihpDefaultConfig #-}

instance EnvVarReader AppPort where
    envStringToValue :: ByteString -> Either Text AppPort
envStringToValue ByteString
string = Int -> AppPort
AppPort (Int -> AppPort) -> Either Text Int -> Either Text AppPort
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either Text Int
forall valueType.
EnvVarReader valueType =>
ByteString -> Either Text valueType
envStringToValue ByteString
string

instance EnvVarReader RequestLogger.IPAddrSource where
    envStringToValue :: ByteString -> Either Text IPAddrSource
envStringToValue ByteString
"FromHeader" = IPAddrSource -> Either Text IPAddrSource
forall a b. b -> Either a b
Right IPAddrSource
RequestLogger.FromHeader
    envStringToValue ByteString
"FromSocket" = IPAddrSource -> Either Text IPAddrSource
forall a b. b -> Either a b
Right IPAddrSource
RequestLogger.FromSocket
    envStringToValue ByteString
otherwise    = Text -> Either Text IPAddrSource
forall a b. a -> Either a b
Left Text
"Expected 'FromHeader' or 'FromSocket'"

findOption :: forall option. Typeable option => State.StateT TMap.TMap IO option
findOption :: forall option. Typeable option => StateT TMap IO option
findOption = option -> Maybe option -> option
forall a. a -> Maybe a -> a
fromMaybe (Text -> option
forall a. Text -> a
error Text
optionNotFoundErrorMessage) (Maybe option -> option)
-> StateT TMap IO (Maybe option) -> StateT TMap IO option
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall option. Typeable option => StateT TMap IO (Maybe option)
findOptionOrNothing @option
    where
        optionNotFoundErrorMessage :: Text
optionNotFoundErrorMessage = Text
"findOption: Could not find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a. Show a => a -> Text
show (option -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf (option
forall a. HasCallStack => a
undefined :: option))
{-# INLINABLE findOption #-}

findOptionOrNothing :: forall option. Typeable option => State.StateT TMap.TMap IO (Maybe option)
findOptionOrNothing :: forall option. Typeable option => StateT TMap IO (Maybe option)
findOptionOrNothing = do
    options <- StateT TMap IO TMap
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
    options
        |> TMap.lookup @option
        |> pure
{-# INLINABLE findOptionOrNothing #-}

buildFrameworkConfig :: ConfigBuilder -> IO FrameworkConfig
buildFrameworkConfig :: StateT TMap IO () -> IO FrameworkConfig
buildFrameworkConfig StateT TMap IO ()
appConfig = do
    let resolve :: StateT TMap IO FrameworkConfig
resolve = do
            (AppHostname appHostname) <- forall option. Typeable option => StateT TMap IO option
findOption @AppHostname
            environment <- findOption @Environment
            (AppPort appPort) <- findOption @AppPort
            (BaseUrl baseUrl) <- findOption @BaseUrl
            (RequestLoggerMiddleware requestLoggerMiddleware) <- findOption @RequestLoggerMiddleware
            (SessionCookie sessionCookie) <- findOption @SessionCookie
            (DatabaseUrl databaseUrl) <- findOption @DatabaseUrl
            cssFramework <- findOption @CSSFramework
            logger <- findOption @Logger
            exceptionTracker <- findOption @ExceptionTracker
            corsResourcePolicy <- findOptionOrNothing @Cors.CorsResourcePolicy
            parseRequestBodyOptions <- findOption @WaiParse.ParseRequestBodyOptions
            (IdeBaseUrl ideBaseUrl) <- findOption @IdeBaseUrl
            (RLSAuthenticatedRole rlsAuthenticatedRole) <- findOption @RLSAuthenticatedRole
            customMiddleware <- findOption @CustomMiddleware
            initializers <- fromMaybe [] <$> findOptionOrNothing @[Initializer]

            appConfig <- State.get


            pure FrameworkConfig { .. }

    (frameworkConfig, _) <- StateT TMap IO FrameworkConfig
-> TMap -> IO (FrameworkConfig, TMap)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (StateT TMap IO ()
appConfig StateT TMap IO () -> StateT TMap IO () -> StateT TMap IO ()
forall a b.
StateT TMap IO a -> StateT TMap IO b -> StateT TMap IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT TMap IO ()
ihpDefaultConfig StateT TMap IO ()
-> StateT TMap IO FrameworkConfig -> StateT TMap IO FrameworkConfig
forall a b.
StateT TMap IO a -> StateT TMap IO b -> StateT TMap IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT TMap IO FrameworkConfig
resolve) TMap
TMap.empty

    pure frameworkConfig
{-# INLINABLE buildFrameworkConfig #-}

-- | Returns the default IHP session cookie configuration. Useful when you want to override the default settings in 'sessionCookie'
defaultIHPSessionCookie :: Text -> Cookie.SetCookie
defaultIHPSessionCookie :: Text -> SetCookie
defaultIHPSessionCookie Text
baseUrl = SetCookie
forall a. Default a => a
def
    { Cookie.setCookiePath = Just "/"
    , Cookie.setCookieMaxAge = Just (fromIntegral (60 * 60 * 24 * 30))
    , Cookie.setCookieSameSite = Just Cookie.sameSiteLax
    , Cookie.setCookieHttpOnly = True
    , Cookie.setCookieSecure = "https://" `Text.isPrefixOf` baseUrl
    }

data RootApplication = RootApplication deriving (RootApplication -> RootApplication -> Bool
(RootApplication -> RootApplication -> Bool)
-> (RootApplication -> RootApplication -> Bool)
-> Eq RootApplication
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RootApplication -> RootApplication -> Bool
== :: RootApplication -> RootApplication -> Bool
$c/= :: RootApplication -> RootApplication -> Bool
/= :: RootApplication -> RootApplication -> Bool
Eq, Int -> RootApplication -> ShowS
[RootApplication] -> ShowS
RootApplication -> String
(Int -> RootApplication -> ShowS)
-> (RootApplication -> String)
-> ([RootApplication] -> ShowS)
-> Show RootApplication
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RootApplication -> ShowS
showsPrec :: Int -> RootApplication -> ShowS
$cshow :: RootApplication -> String
show :: RootApplication -> String
$cshowList :: [RootApplication] -> ShowS
showList :: [RootApplication] -> ShowS
Show)

defaultPort :: Int
defaultPort :: Int
defaultPort = Int
8000

defaultDatabaseUrl :: HasCallStack => IO ByteString
defaultDatabaseUrl :: HasCallStack => IO ByteString
defaultDatabaseUrl = do
    currentDirectoryOsPath <- IO OsPath
Directory.getCurrentDirectory
    currentDirectory <- decodeUtf currentDirectoryOsPath
    let defaultDatabaseUrl = ByteString
"postgresql:///app?host=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
currentDirectory ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/build/db"
    envOrDefault "DATABASE_URL" defaultDatabaseUrl

defaultLoggerForEnv :: HasCallStack => Environment -> IO Logger
defaultLoggerForEnv :: HasCallStack => Environment -> IO Logger
defaultLoggerForEnv = \case
    Environment
Development -> IO Logger
defaultLogger
    Environment
Production -> LoggerSettings -> IO Logger
newLogger LoggerSettings
forall a. Default a => a
def { level = Info }


-- Returns 'True' when the application is running in a given environment
isEnvironment :: (?context :: context, ConfigProvider context) => Environment -> Bool
isEnvironment :: forall context.
(?context::context, ConfigProvider context) =>
Environment -> Bool
isEnvironment Environment
environment = context
?context::context
?context.frameworkConfig.environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
environment
{-# INLINABLE isEnvironment #-}

-- | Returns 'True'  when the application is running in Development mode
--
-- Development mode means that the Development option is configured in Config/Config.hs
--
-- See 'Environment' for documentation on the default differences.
isDevelopment :: (?context :: context, ConfigProvider context) => Bool
isDevelopment :: forall context. (?context::context, ConfigProvider context) => Bool
isDevelopment = Environment -> Bool
forall context.
(?context::context, ConfigProvider context) =>
Environment -> Bool
isEnvironment Environment
Development
{-# INLINABLE isDevelopment #-}

-- | Returns 'True' when the application is running in Production mode
--
-- Production mode means that the Production option is configured in Config/Config.hs
--
-- See 'Environment' for documentation on the default differences.
isProduction :: (?context :: context, ConfigProvider context) => Bool
isProduction :: forall context. (?context::context, ConfigProvider context) => Bool
isProduction = Environment -> Bool
forall context.
(?context::context, ConfigProvider context) =>
Environment -> Bool
isEnvironment Environment
Production
{-# INLINABLE isProduction #-}

defaultCorsResourcePolicy :: Maybe Cors.CorsResourcePolicy
defaultCorsResourcePolicy :: Maybe CorsResourcePolicy
defaultCorsResourcePolicy = Maybe CorsResourcePolicy
forall a. Maybe a
Nothing

-- | Builds a config and calls the provided callback.
--
-- Once the callback has returned the resources allocated by the config are closed. Specifcally
-- this will close open log file handles.
--
-- __Example:__
--
-- > import Config (config)
-- >
-- > withFrameworkConfig config \frameworkConfig -> do
-- >     -- Do something with the FrameworkConfig here
--
withFrameworkConfig :: ConfigBuilder -> (FrameworkConfig -> IO result) -> IO result
withFrameworkConfig :: forall result.
StateT TMap IO () -> (FrameworkConfig -> IO result) -> IO result
withFrameworkConfig StateT TMap IO ()
configBuilder = IO FrameworkConfig
-> (FrameworkConfig -> IO ())
-> (FrameworkConfig -> IO result)
-> IO result
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket (StateT TMap IO () -> IO FrameworkConfig
buildFrameworkConfig StateT TMap IO ()
configBuilder) (\FrameworkConfig
frameworkConfig -> FrameworkConfig
frameworkConfig.logger.cleanup)

-- | Wraps an Exception thrown during the config process, but adds a CallStack
--
-- Inspired by https://maksbotan.github.io/posts/2021-01-20-callstacks.html
--
data ExceptionWithCallStack = ExceptionWithCallStack CallStack SomeException

instance Prelude.Show ExceptionWithCallStack where
    show :: ExceptionWithCallStack -> String
show (ExceptionWithCallStack CallStack
callStack SomeException
inner) = SomeException -> String
forall a. Show a => a -> String
Prelude.show SomeException
inner String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallStack -> String
Stack.prettyCallStack CallStack
callStack

instance Exception ExceptionWithCallStack

-- | Runs IO inside the config process
--
-- It works like 'liftIO', but attaches a CallStack on error. Without this it would be hard to see where
-- an error during the config setup comes from.
--
-- All call-sites of this function should also have a @HasCallStack@ constraint to provide helpful information in the call stack.
--
-- See https://github.com/digitallyinduced/ihp/issues/1503
configIO :: (MonadIO monad, HasCallStack) => IO result -> monad result
configIO :: forall (monad :: * -> *) result.
(MonadIO monad, HasCallStack) =>
IO result -> monad result
configIO IO result
action = IO result -> monad result
forall a. IO a -> monad a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO result
action IO result -> (SomeException -> IO result) -> IO result
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> IO result
forall {m :: * -> *} {a}. MonadThrow m => SomeException -> m a
wrapWithCallStack)
    where
        wrapWithCallStack :: SomeException -> m a
wrapWithCallStack SomeException
exception = ExceptionWithCallStack -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwIO (CallStack -> SomeException -> ExceptionWithCallStack
ExceptionWithCallStack CallStack
HasCallStack => CallStack
Stack.callStack SomeException
exception)