ihp-1.4.0: IHP/FrameworkConfig.hs
{-# 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)