{-# LANGUAGE ConstraintKinds #-}
module IHP.FrameworkConfig where

import IHP.Prelude
import System.Directory (getCurrentDirectory)
import IHP.Environment
import qualified Data.Text as Text
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Web.Cookie as Cookie
import IHP.Mail.Types
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
import IHP.Log.Types
import IHP.Log (makeRequestLogger, defaultRequestLogger)
import Network.Wai
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.ModelSupport
import IHP.EnvVar

import qualified Prelude
import qualified GHC.Stack as Stack

import qualified Control.Concurrent as Concurrent

newtype AppHostname = AppHostname Text
newtype AppPort = AppPort Int
newtype BaseUrl = BaseUrl Text

-- | Provides IHP with a middleware to log requests and responses.
--
-- By default this uses the RequestLogger middleware from wai-extra. Take a look at the wai-extra
-- documentation when you want to customize the request logging.
--
-- See https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html
--
--
-- Set @requestLoggerMiddleware = \application -> application@ to disable request logging.
newtype RequestLoggerMiddleware = RequestLoggerMiddleware Middleware

-- | Provides the default settings for the session cookie.
--
-- - Max Age: 30 days
-- - Same Site Policy: Lax
-- - HttpOnly (no access through JS)
-- - secure, when baseUrl is a https url
--
-- Override this to set e.g. a custom max age or change the default same site policy.
--
-- __Example: Set max age to 90 days__
-- > sessionCookie = defaultIHPSessionCookie { Cookie.setCookieMaxAge = Just (fromIntegral (60 * 60 * 24 * 90)) }
newtype SessionCookie = SessionCookie Cookie.SetCookie

-- | How long db connection are kept alive inside the connecton pool when they're idle
newtype DBPoolIdleTime = DBPoolIdleTime NominalDiffTime

-- | Max number of db connections the connection pool can open to the database
newtype DBPoolMaxConnections = DBPoolMaxConnections Int

newtype DatabaseUrl = DatabaseUrl ByteString

type ConfigBuilder = State.StateT TMap.TMap IO ()

-- | Interface for exception tracking services such as sentry
newtype ExceptionTracker = ExceptionTracker { ExceptionTracker -> Maybe Request -> SomeException -> IO ()
onException :: Maybe Request -> SomeException -> IO () }

-- | Typically "http://localhost:8001", Url where the IDE is running
newtype IdeBaseUrl = IdeBaseUrl Text

-- | Postgres role to be used for making queries with Row level security enabled
newtype RLSAuthenticatedRole = RLSAuthenticatedRole Text

newtype AssetVersion = AssetVersion Text

newtype CustomMiddleware = CustomMiddleware Middleware

newtype DataSyncMaxSubscriptionsPerConnection = DataSyncMaxSubscriptionsPerConnection Int
newtype DataSyncMaxTransactionsPerConnection = DataSyncMaxTransactionsPerConnection Int

newtype Initializer = Initializer { Initializer
-> (?context::FrameworkConfig, ?modelContext::ModelContext) =>
   IO ()
onStartup :: (?context :: FrameworkConfig, ?modelContext :: ModelContext) => IO () }

-- | 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
    [Initializer]
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]
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 }]
    (TMap -> TMap) -> StateT TMap IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\TMap
map -> TMap
map
            TMap -> (TMap -> TMap) -> TMap
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Typeable a => TMap -> TMap
TMap.delete @[Initializer]
            TMap -> (TMap -> TMap) -> TMap
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Initializer] -> TMap -> TMap
forall a. Typeable a => a -> TMap -> TMap
TMap.insert [Initializer]
newInitializers
        )

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

    AppHostname -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (AppHostname -> StateT TMap IO ())
-> AppHostname -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Text -> AppHostname
AppHostname Text
"localhost"

    AppPort
port :: AppPort <- ByteString -> AppPort -> StateT TMap IO AppPort
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
"PORT" (Int -> AppPort
AppPort Int
defaultPort)
    AppPort -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option AppPort
port

    ExceptionTracker -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (ExceptionTracker -> StateT TMap IO ())
-> ExceptionTracker -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe Request -> SomeException -> IO ()) -> ExceptionTracker
ExceptionTracker Maybe Request -> SomeException -> IO ()
Warp.defaultOnException

    Environment
environment <- forall option. Typeable option => StateT TMap IO option
findOption @Environment

    Logger
defaultLogger <- IO Logger -> StateT TMap IO Logger
forall (monad :: * -> *) result.
(MonadIO monad, HasCallStack) =>
IO result -> monad result
configIO (HasCallStack => Environment -> IO Logger
Environment -> IO Logger
defaultLoggerForEnv Environment
environment)
    Logger -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option Logger
defaultLogger
    Logger
logger <- forall option. Typeable option => StateT TMap IO option
findOption @Logger

    IPAddrSource
requestLoggerIpAddrSource <- ByteString -> IPAddrSource -> StateT TMap IO IPAddrSource
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
"IHP_REQUEST_LOGGER_IP_ADDR_SOURCE" IPAddrSource
RequestLogger.FromSocket

    RequestLoggerMiddleware
reqLoggerMiddleware <- IO RequestLoggerMiddleware
-> StateT TMap IO RequestLoggerMiddleware
forall (monad :: * -> *) result.
(MonadIO monad, HasCallStack) =>
IO result -> monad result
configIO (IO RequestLoggerMiddleware
 -> StateT TMap IO RequestLoggerMiddleware)
-> IO RequestLoggerMiddleware
-> StateT TMap IO RequestLoggerMiddleware
forall a b. (a -> b) -> a -> b
$
            case Environment
environment of
                Environment
Development -> do
                                    Middleware
reqLogger <- (Logger
logger Logger -> (Logger -> IO Middleware) -> IO Middleware
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Logger -> IO Middleware
defaultRequestLogger)
                                    RequestLoggerMiddleware -> IO RequestLoggerMiddleware
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Middleware -> RequestLoggerMiddleware
RequestLoggerMiddleware Middleware
reqLogger)
                Environment
Production  ->  do
                                    Middleware
reqLogger <- (Logger
logger Logger -> (Logger -> IO Middleware) -> IO Middleware
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> RequestLoggerSettings -> Logger -> IO Middleware
makeRequestLogger RequestLoggerSettings
forall a. Default a => a
def { RequestLogger.outputFormat = RequestLogger.Apache requestLoggerIpAddrSource })
                                    RequestLoggerMiddleware -> IO RequestLoggerMiddleware
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Middleware -> RequestLoggerMiddleware
RequestLoggerMiddleware Middleware
reqLogger)


    RequestLoggerMiddleware -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (RequestLoggerMiddleware -> StateT TMap IO ())
-> RequestLoggerMiddleware -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ RequestLoggerMiddleware
reqLoggerMiddleware

    Maybe CorsResourcePolicy -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (Maybe CorsResourcePolicy -> StateT TMap IO ())
-> Maybe CorsResourcePolicy -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Maybe CorsResourcePolicy
defaultCorsResourcePolicy

    MailServer -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (MailServer -> StateT TMap IO ())
-> MailServer -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ MailServer
Sendmail

    ByteString
databaseUrl <- IO ByteString -> StateT TMap IO ByteString
forall (monad :: * -> *) result.
(MonadIO monad, HasCallStack) =>
IO result -> monad result
configIO IO ByteString
HasCallStack => IO ByteString
defaultDatabaseUrl

    DatabaseUrl -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (DatabaseUrl -> StateT TMap IO ())
-> DatabaseUrl -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> DatabaseUrl
DatabaseUrl ByteString
databaseUrl
    DBPoolIdleTime -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (DBPoolIdleTime -> StateT TMap IO ())
-> DBPoolIdleTime -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DBPoolIdleTime
DBPoolIdleTime (NominalDiffTime -> DBPoolIdleTime)
-> NominalDiffTime -> DBPoolIdleTime
forall a b. (a -> b) -> a -> b
$
            case Environment
environment of
                Environment
Development -> NominalDiffTime
2
                Environment
Production -> NominalDiffTime
60

    -- poolMaxResources must not be smaller than numStripes
    -- https://github.com/digitallyinduced/ihp/issues/1959
    Int
numCapabilities <- IO Int -> StateT TMap IO Int
forall (monad :: * -> *) result.
(MonadIO monad, HasCallStack) =>
IO result -> monad result
configIO IO Int
Concurrent.getNumCapabilities
    DBPoolMaxConnections -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (DBPoolMaxConnections -> StateT TMap IO ())
-> DBPoolMaxConnections -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Int -> DBPoolMaxConnections
DBPoolMaxConnections (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
numCapabilities Int
20)

    (AppPort Int
port) <- forall option. Typeable option => StateT TMap IO option
findOption @AppPort

    -- The IHP_BASEURL env var can override the hardcoded base url in Config.hs
    Maybe Text
ihpBaseUrlEnvVar <- ByteString -> StateT TMap IO (Maybe Text)
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> monad (Maybe result)
envOrNothing ByteString
"IHP_BASEURL"
    case Maybe Text
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 Text
appHostname) <- forall option. Typeable option => StateT TMap IO option
findOption @AppHostname
            BaseUrl -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (BaseUrl -> StateT TMap IO ()) -> BaseUrl -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseUrl
BaseUrl (Text
"http://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
appHostname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
80 then Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
port else Text
""))

    (BaseUrl Text
currentBaseUrl) <- forall option. Typeable option => StateT TMap IO option
findOption @BaseUrl
    SessionCookie -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (SessionCookie -> StateT TMap IO ())
-> SessionCookie -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ SetCookie -> SessionCookie
SessionCookie (Text -> SetCookie
defaultIHPSessionCookie Text
currentBaseUrl)

    ParseRequestBodyOptions -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option ParseRequestBodyOptions
WaiParse.defaultParseRequestBodyOptions

    CSSFramework -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option CSSFramework
bootstrap

    Bool -> StateT TMap IO () -> StateT TMap IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Environment
environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Development) do
        Text
ihpIdeBaseUrl <- ByteString -> Text -> StateT TMap IO Text
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
"IHP_IDE_BASEURL" (Text
"http://localhost:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
port Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
        IdeBaseUrl -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (Text -> IdeBaseUrl
IdeBaseUrl Text
ihpIdeBaseUrl)

    Text
rlsAuthenticatedRole <- ByteString -> Text -> StateT TMap IO Text
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
"IHP_RLS_AUTHENTICATED_ROLE" Text
"ihp_authenticated"
    RLSAuthenticatedRole -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (RLSAuthenticatedRole -> StateT TMap IO ())
-> RLSAuthenticatedRole -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Text -> RLSAuthenticatedRole
RLSAuthenticatedRole Text
rlsAuthenticatedRole

    StateT TMap IO ()
initAssetVersion

    Int
dataSyncMaxSubscriptionsPerConnection <- ByteString -> Int -> StateT TMap IO Int
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
"IHP_DATASYNC_MAX_SUBSCRIPTIONS_PER_CONNECTION" Int
128
    Int
dataSyncMaxTransactionsPerConnection <- ByteString -> Int -> StateT TMap IO Int
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
"IHP_DATASYNC_MAX_TRANSACTIONS_PER_CONNECTION" Int
10
    DataSyncMaxSubscriptionsPerConnection -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (DataSyncMaxSubscriptionsPerConnection -> StateT TMap IO ())
-> DataSyncMaxSubscriptionsPerConnection -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Int -> DataSyncMaxSubscriptionsPerConnection
DataSyncMaxSubscriptionsPerConnection Int
dataSyncMaxSubscriptionsPerConnection
    DataSyncMaxTransactionsPerConnection -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (DataSyncMaxTransactionsPerConnection -> StateT TMap IO ())
-> DataSyncMaxTransactionsPerConnection -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Int -> DataSyncMaxTransactionsPerConnection
DataSyncMaxTransactionsPerConnection Int
dataSyncMaxTransactionsPerConnection

    CustomMiddleware -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (CustomMiddleware -> StateT TMap IO ())
-> CustomMiddleware -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Middleware -> CustomMiddleware
CustomMiddleware Middleware
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
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'"

initAssetVersion :: ConfigBuilder
initAssetVersion :: StateT TMap IO ()
initAssetVersion = do
    Maybe Text
ihpAssetVersion <- ByteString -> StateT TMap IO (Maybe Text)
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> monad (Maybe result)
envOrNothing ByteString
"IHP_ASSET_VERSION"
    let assetVersion :: Text
assetVersion = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"dev" Maybe Text
ihpAssetVersion
    AssetVersion -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (Text -> AssetVersion
AssetVersion Text
assetVersion)

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
    TMap
options <- StateT TMap IO TMap
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
    TMap
options
        TMap -> (TMap -> Maybe option) -> Maybe option
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Typeable a => TMap -> Maybe a
TMap.lookup @option
        Maybe option
-> (Maybe option -> StateT TMap IO (Maybe option))
-> StateT TMap IO (Maybe option)
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Maybe option -> StateT TMap IO (Maybe option)
forall a. a -> StateT TMap IO a
forall (f :: * -> *) a. Applicative f => a -> f a
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 Text
appHostname) <- forall option. Typeable option => StateT TMap IO option
findOption @AppHostname
            Environment
environment <- forall option. Typeable option => StateT TMap IO option
findOption @Environment
            (AppPort Int
appPort) <- forall option. Typeable option => StateT TMap IO option
findOption @AppPort
            (BaseUrl Text
baseUrl) <- forall option. Typeable option => StateT TMap IO option
findOption @BaseUrl
            (RequestLoggerMiddleware Middleware
requestLoggerMiddleware) <- forall option. Typeable option => StateT TMap IO option
findOption @RequestLoggerMiddleware
            (SessionCookie SetCookie
sessionCookie) <- forall option. Typeable option => StateT TMap IO option
findOption @SessionCookie
            MailServer
mailServer <- forall option. Typeable option => StateT TMap IO option
findOption @MailServer
            (DBPoolIdleTime NominalDiffTime
dbPoolIdleTime) <- forall option. Typeable option => StateT TMap IO option
findOption @DBPoolIdleTime
            (DBPoolMaxConnections Int
dbPoolMaxConnections) <- forall option. Typeable option => StateT TMap IO option
findOption @DBPoolMaxConnections
            (DatabaseUrl ByteString
databaseUrl) <- forall option. Typeable option => StateT TMap IO option
findOption @DatabaseUrl
            CSSFramework
cssFramework <- forall option. Typeable option => StateT TMap IO option
findOption @CSSFramework
            Logger
logger <- forall option. Typeable option => StateT TMap IO option
findOption @Logger
            ExceptionTracker
exceptionTracker <- forall option. Typeable option => StateT TMap IO option
findOption @ExceptionTracker
            Maybe CorsResourcePolicy
corsResourcePolicy <- forall option. Typeable option => StateT TMap IO (Maybe option)
findOptionOrNothing @Cors.CorsResourcePolicy
            ParseRequestBodyOptions
parseRequestBodyOptions <- forall option. Typeable option => StateT TMap IO option
findOption @WaiParse.ParseRequestBodyOptions
            (IdeBaseUrl Text
ideBaseUrl) <- forall option. Typeable option => StateT TMap IO option
findOption @IdeBaseUrl
            (RLSAuthenticatedRole Text
rlsAuthenticatedRole) <- forall option. Typeable option => StateT TMap IO option
findOption @RLSAuthenticatedRole
            (AssetVersion Text
assetVersion) <- forall option. Typeable option => StateT TMap IO option
findOption @AssetVersion
            Maybe Text
assetBaseUrl <- ByteString -> StateT TMap IO (Maybe Text)
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> monad (Maybe result)
envOrNothing ByteString
"IHP_ASSET_BASEURL"
            CustomMiddleware
customMiddleware <- forall option. Typeable option => StateT TMap IO option
findOption @CustomMiddleware
            [Initializer]
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]

            TMap
appConfig <- StateT TMap IO TMap
forall (m :: * -> *) s. Monad m => StateT s m s
State.get


            FrameworkConfig -> StateT TMap IO FrameworkConfig
forall a. a -> StateT TMap IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrameworkConfig { Int
[Initializer]
Maybe Text
Maybe CorsResourcePolicy
ByteString
Text
NominalDiffTime
Logger
TMap
MailServer
ParseRequestBodyOptions
Environment
CSSFramework
SetCookie
CustomMiddleware
ExceptionTracker
Middleware
appHostname :: Text
environment :: Environment
appPort :: Int
baseUrl :: Text
requestLoggerMiddleware :: Middleware
sessionCookie :: SetCookie
mailServer :: MailServer
dbPoolIdleTime :: NominalDiffTime
dbPoolMaxConnections :: Int
databaseUrl :: ByteString
cssFramework :: CSSFramework
logger :: Logger
exceptionTracker :: ExceptionTracker
corsResourcePolicy :: Maybe CorsResourcePolicy
parseRequestBodyOptions :: ParseRequestBodyOptions
ideBaseUrl :: Text
rlsAuthenticatedRole :: Text
assetVersion :: Text
assetBaseUrl :: Maybe Text
customMiddleware :: CustomMiddleware
initializers :: [Initializer]
appConfig :: TMap
initializers :: [Initializer]
customMiddleware :: CustomMiddleware
assetBaseUrl :: Maybe Text
assetVersion :: Text
rlsAuthenticatedRole :: Text
ideBaseUrl :: Text
parseRequestBodyOptions :: ParseRequestBodyOptions
corsResourcePolicy :: Maybe CorsResourcePolicy
appConfig :: TMap
exceptionTracker :: ExceptionTracker
logger :: Logger
cssFramework :: CSSFramework
dbPoolMaxConnections :: Int
dbPoolIdleTime :: NominalDiffTime
databaseUrl :: ByteString
mailServer :: MailServer
sessionCookie :: SetCookie
requestLoggerMiddleware :: Middleware
baseUrl :: Text
appPort :: Int
environment :: Environment
appHostname :: Text
.. }

    (FrameworkConfig
frameworkConfig, TMap
_) <- 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

    FrameworkConfig -> IO FrameworkConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrameworkConfig
frameworkConfig
{-# INLINABLE buildFrameworkConfig #-}

data FrameworkConfig = FrameworkConfig
    { FrameworkConfig -> Text
appHostname :: !Text
    , FrameworkConfig -> Environment
environment :: !Environment
    , FrameworkConfig -> Int
appPort :: !Int
    , FrameworkConfig -> Text
baseUrl :: !Text

    -- | Provides IHP with a middleware to log requests and responses.
    --
    -- By default this uses the RequestLogger middleware from wai-extra. Take a look at the wai-extra
    -- documentation when you want to customize the request logging.
    --
    -- See https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html
    --
    --
    -- Set @requestLoggerMiddleware = \application -> application@ to disable request logging.
    , FrameworkConfig -> Middleware
requestLoggerMiddleware :: !Middleware

    -- | Provides the default settings for the session cookie.
    --
    -- - Max Age: 30 days
    -- - Same Site Policy: Lax
    -- - HttpOnly (no access through JS)
    -- - secure, when baseUrl is a https url
    --
    -- Override this to set e.g. a custom max age or change the default same site policy.
    --
    -- __Example: Set max age to 90 days__
    -- > sessionCookie = defaultIHPSessionCookie { Cookie.setCookieMaxAge = Just (fromIntegral (60 * 60 * 24 * 90)) }
    , FrameworkConfig -> SetCookie
sessionCookie :: !Cookie.SetCookie

    , FrameworkConfig -> MailServer
mailServer :: !MailServer

    , FrameworkConfig -> ByteString
databaseUrl :: !ByteString
    -- | How long db connection are kept alive inside the connecton pool when they're idle
    , FrameworkConfig -> NominalDiffTime
dbPoolIdleTime :: !NominalDiffTime

    -- | Max number of db connections the connection pool can open to the database
    , FrameworkConfig -> Int
dbPoolMaxConnections :: !Int

    -- | Bootstrap 4 by default
    --
    -- Override this if you use a CSS framework that is not bootstrap
    , FrameworkConfig -> CSSFramework
cssFramework :: !CSSFramework
    , FrameworkConfig -> Logger
logger :: !Logger
    , FrameworkConfig -> ExceptionTracker
exceptionTracker :: !ExceptionTracker

    -- | Custom 'option's from @Config.hs@ are stored here
    --
    -- To access a custom option here, first set it up inside @Config.hs@. This example
    -- reads a string from a env variable on app startup and makes it available to the app
    -- by saving it into the application context:
    --
    -- > -- Config.hs:
    -- >
    -- > newtype RedisUrl = RedisUrl String
    -- >
    -- > config :: ConfigBuilder
    -- > config = do
    -- >     option Development
    -- >     option (AppHostname "localhost")
    -- >
    -- >     redisUrl <- env "REDIS_URL"
    -- >     option (RedisUrl redisUrl)
    --
    -- This redis url can be access from all IHP entrypoints using the ?applicationContext that is in scope:
    --
    -- > import qualified Data.TMap as TMap
    -- > import Config -- For accessing the RedisUrl data type
    -- >
    -- > action MyAction = do
    -- >     let appConfig = ?context.frameworkConfig.appConfig
    -- >     let (RedisUrl redisUrl) = appConfig
    -- >                |> TMap.lookup @RedisUrl
    -- >                |> fromMaybe (error "Could not find RedisUrl in config")
    -- >
    , FrameworkConfig -> TMap
appConfig :: !TMap.TMap

    -- | Configures CORS headers for the application. By default this is set to 'Nothing', and the server will not respond with any CORS headers
    --
    -- You can provide a custom CORS policy in @Config.hs@:
    --
    -- > -- Config.hs
    -- > import qualified Network.Wai.Middleware.Cors as Cors
    -- >
    -- > config :: ConfigBuilder
    -- > config = do
    -- >     option Development
    -- >     option (AppHostname "localhost")
    -- >
    -- >     option Cors.simpleCorsResourcePolicy
    -- >
    --
    -- Take a look at the documentation of wai-cors https://hackage.haskell.org/package/wai-cors-0.2.7/docs/Network-Wai-Middleware-Cors.html for understanding what @simpleCorsResourcePolicy@ is doing
    --
    -- You can specify CORS origins like this:
    --
    -- > -- Config.hs
    -- > import qualified Network.Wai.Middleware.Cors as Cors
    -- >
    -- > config :: ConfigBuilder
    -- > config = do
    -- >     option Development
    -- >     option (AppHostname "localhost")
    -- >
    -- >     -- The boolean True specifies if credentials are allowed for the request. You still need to set withCredentials on your XmlHttpRequest
    -- >     option Cors.simpleCorsResourcePolicy { Cors.corsOrigins = Just (["localhost"], True) }
    -- >
    , FrameworkConfig -> Maybe CorsResourcePolicy
corsResourcePolicy :: !(Maybe Cors.CorsResourcePolicy)

    -- | Configures the limits for request parameters, uploaded files, maximum number of headers etc.
    --
    -- IHP is using 'Network.Wai.Parse.parseRequestBodyEx' for parsing the HTTP request. By default it applies certain limits
    -- to avoid a single request overloading the server.
    --
    -- You can find the default limits here: https://hackage.haskell.org/package/wai-extra-3.1.6/docs/Network-Wai-Parse.html#v:defaultParseRequestBodyOptions
    --
    -- You can override the default limits like this:
    --
    -- > -- Config.hs
    -- > import qualified Network.Wai.Parse as WaiParse
    -- >
    -- > config :: ConfigBuilder
    -- > config = do
    -- >     option Development
    -- >     option (AppHostname "localhost")
    -- >
    -- >     -- We extend the default options here
    -- >     option $ WaiParse.defaultParseRequestBodyOptions
    -- >             |> WaiParse.setMaxRequestNumFiles 20 -- Increase count of allowed files per request
    -- >
    , FrameworkConfig -> ParseRequestBodyOptions
parseRequestBodyOptions :: !WaiParse.ParseRequestBodyOptions

    -- | Used by the dev server. This field cannot be strict.
    , FrameworkConfig -> Text
ideBaseUrl :: Text

    -- | See IHP.DataSync.Role
    , FrameworkConfig -> Text
rlsAuthenticatedRole :: !Text

    -- | The asset version is used for cache busting
    --
    -- If you deploy IHP on your own, you should provide the IHP_ASSET_VERSION
    -- env variable with e.g. the git commit hash of the production build.
    --
    -- If IHP cannot figure out an asset version, it will fallback to the static
    -- string @"dev"@.
    --
    , FrameworkConfig -> Text
assetVersion :: !Text

    -- | Base URL used by the 'assetPath' helper. Useful to move your static files to a CDN
    , FrameworkConfig -> Maybe Text
assetBaseUrl :: !(Maybe Text)

    -- | User provided WAI middleware that is run after IHP's middleware stack.
    , FrameworkConfig -> CustomMiddleware
customMiddleware :: !CustomMiddleware
    , FrameworkConfig -> [Initializer]
initializers :: ![Initializer]
}

instance HasField "frameworkConfig" FrameworkConfig FrameworkConfig where
    getField :: FrameworkConfig -> FrameworkConfig
getField FrameworkConfig
frameworkConfig = FrameworkConfig
frameworkConfig

type ConfigProvider context = HasField "frameworkConfig" context FrameworkConfig

-- | 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
    String
currentDirectory <- IO String
getCurrentDirectory
    let defaultDatabaseUrl :: ByteString
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"
    ByteString -> ByteString -> IO ByteString
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
"DATABASE_URL" ByteString
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
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
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)

initModelContext :: FrameworkConfig -> IO ModelContext
initModelContext :: FrameworkConfig -> IO ModelContext
initModelContext FrameworkConfig { Environment
environment :: FrameworkConfig -> Environment
environment :: Environment
environment, NominalDiffTime
dbPoolIdleTime :: FrameworkConfig -> NominalDiffTime
dbPoolIdleTime :: NominalDiffTime
dbPoolIdleTime, Int
dbPoolMaxConnections :: FrameworkConfig -> Int
dbPoolMaxConnections :: Int
dbPoolMaxConnections, ByteString
databaseUrl :: FrameworkConfig -> ByteString
databaseUrl :: ByteString
databaseUrl, Logger
logger :: FrameworkConfig -> Logger
logger :: Logger
logger } = do
    let isDevelopment :: Bool
isDevelopment = Environment
environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Development
    ModelContext
modelContext <- NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext NominalDiffTime
dbPoolIdleTime Int
dbPoolMaxConnections ByteString
databaseUrl Logger
logger
    ModelContext -> IO ModelContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext
modelContext

-- | 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 e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO result
forall {a}. SomeException -> IO a
wrapWithCallStack)
    where
        wrapWithCallStack :: SomeException -> IO a
wrapWithCallStack SomeException
exception = ExceptionWithCallStack -> IO a
forall e a. Exception e => e -> IO a
throwIO (CallStack -> SomeException -> ExceptionWithCallStack
ExceptionWithCallStack CallStack
HasCallStack => CallStack
Stack.callStack SomeException
exception)