{-# 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 { 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 { 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 !value = State.modify (\map -> if TMap.member @option map then map else TMap.insert value 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 onStartup = do
    initializers <- fromMaybe [] <$> findOptionOrNothing @[Initializer]
    let newInitializers = initializers <> [Initializer { onStartup }]
    State.modify (\map -> map
            |> TMap.delete @[Initializer]
            |> TMap.insert newInitializers
        )

ihpDefaultConfig :: ConfigBuilder
ihpDefaultConfig = do
    ihpEnv <- envOrDefault "IHP_ENV" 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
                Development -> do
                                    reqLogger <- (logger |> defaultRequestLogger)
                                    pure (RequestLoggerMiddleware reqLogger)
                Production  ->  do
                                    reqLogger <- (logger |> makeRequestLogger def { RequestLogger.outputFormat = RequestLogger.Apache requestLoggerIpAddrSource })
                                    pure (RequestLoggerMiddleware reqLogger)


    option $ reqLoggerMiddleware

    option $ defaultCorsResourcePolicy

    option $ Sendmail

    databaseUrl <- configIO defaultDatabaseUrl

    option $ DatabaseUrl databaseUrl
    option $ DBPoolIdleTime $
            case environment of
                Development -> 2
                Production -> 60

    -- poolMaxResources must not be smaller than numStripes
    -- https://github.com/digitallyinduced/ihp/issues/1959
    numCapabilities <- configIO Concurrent.getNumCapabilities
    option $ DBPoolMaxConnections (max numCapabilities 20)

    (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 baseUrl -> option (BaseUrl baseUrl)
        Nothing -> do
            (AppHostname appHostname) <- 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

    initAssetVersion

    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 string = AppPort <$> envStringToValue string

instance EnvVarReader RequestLogger.IPAddrSource where
    envStringToValue "FromHeader" = Right RequestLogger.FromHeader
    envStringToValue "FromSocket" = Right RequestLogger.FromSocket
    envStringToValue otherwise    = Left "Expected 'FromHeader' or 'FromSocket'"

initAssetVersion :: ConfigBuilder
initAssetVersion = do
    ihpAssetVersion <- envOrNothing "IHP_ASSET_VERSION"
    let assetVersion = fromMaybe "dev" ihpAssetVersion
    option (AssetVersion assetVersion)

findOption :: forall option. Typeable option => State.StateT TMap.TMap IO option
findOption = fromMaybe (error optionNotFoundErrorMessage) <$> findOptionOrNothing @option
    where
        optionNotFoundErrorMessage = "findOption: Could not find " <> show (Typeable.typeOf (undefined :: option))
{-# INLINABLE findOption #-}

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

buildFrameworkConfig :: ConfigBuilder -> IO FrameworkConfig
buildFrameworkConfig appConfig = do
    let resolve = do
            (AppHostname appHostname) <- findOption @AppHostname
            environment <- findOption @Environment
            (AppPort appPort) <- findOption @AppPort
            (BaseUrl baseUrl) <- findOption @BaseUrl
            (RequestLoggerMiddleware requestLoggerMiddleware) <- findOption @RequestLoggerMiddleware
            (SessionCookie sessionCookie) <- findOption @SessionCookie
            mailServer <- findOption @MailServer
            (DBPoolIdleTime dbPoolIdleTime) <- findOption @DBPoolIdleTime
            (DBPoolMaxConnections dbPoolMaxConnections) <- findOption @DBPoolMaxConnections
            (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
            (AssetVersion assetVersion) <- findOption @AssetVersion
            assetBaseUrl <- envOrNothing "IHP_ASSET_BASEURL"
            customMiddleware <- findOption @CustomMiddleware
            initializers <- fromMaybe [] <$> findOptionOrNothing @[Initializer]

            appConfig <- State.get


            pure FrameworkConfig { .. }

    (frameworkConfig, _) <- State.runStateT (appConfig >> ihpDefaultConfig >> resolve) TMap.empty

    pure frameworkConfig
{-# INLINABLE buildFrameworkConfig #-}

data FrameworkConfig = FrameworkConfig
    { appHostname :: !Text
    , environment :: !Environment
    , appPort :: !Int
    , 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.
    , 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)) }
    , sessionCookie :: !Cookie.SetCookie

    , mailServer :: !MailServer

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

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

    -- | Bootstrap 4 by default
    --
    -- Override this if you use a CSS framework that is not bootstrap
    , cssFramework :: !CSSFramework
    , logger :: !Logger
    , 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")
    -- >
    , 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) }
    -- >
    , 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
    -- >
    , parseRequestBodyOptions :: !WaiParse.ParseRequestBodyOptions

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

    -- | See IHP.DataSync.Role
    , 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"@.
    --
    , assetVersion :: !Text

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

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

instance HasField "frameworkConfig" FrameworkConfig FrameworkConfig where
    getField 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 baseUrl = 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 (Eq, Show)

defaultPort :: Int
defaultPort = 8000

defaultDatabaseUrl :: HasCallStack => IO ByteString
defaultDatabaseUrl = do
    currentDirectory <- getCurrentDirectory
    let defaultDatabaseUrl = "postgresql:///app?host=" <> cs currentDirectory <> "/build/db"
    envOrDefault "DATABASE_URL" defaultDatabaseUrl

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


-- Returns 'True' when the application is running in a given environment
isEnvironment :: (?context :: context, ConfigProvider context) => Environment -> Bool
isEnvironment environment = ?context.frameworkConfig.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 = isEnvironment 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 = isEnvironment Production
{-# INLINABLE isProduction #-}

defaultCorsResourcePolicy :: Maybe Cors.CorsResourcePolicy
defaultCorsResourcePolicy = 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 configBuilder = Exception.bracket (buildFrameworkConfig configBuilder) (\frameworkConfig -> frameworkConfig.logger.cleanup)

initModelContext :: FrameworkConfig -> IO ModelContext
initModelContext FrameworkConfig { environment, dbPoolIdleTime, dbPoolMaxConnections, databaseUrl, logger } = do
    let isDevelopment = environment == Development
    modelContext <- createModelContext dbPoolIdleTime dbPoolMaxConnections databaseUrl logger
    pure 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 callStack inner) = Prelude.show inner <> "\n" <> Stack.prettyCallStack 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 action = liftIO (action `catch` wrapWithCallStack)
    where
        wrapWithCallStack exception = throwIO (ExceptionWithCallStack Stack.callStack exception)