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 System.Posix.Env.ByteString as Posix
import Data.String.Interpolate.IsString (i)
import qualified Control.Exception as Exception
import IHP.ModelSupport
newtype AppHostname = AppHostname Text
newtype AppPort = AppPort Int
newtype BaseUrl = BaseUrl Text
newtype RequestLoggerMiddleware = RequestLoggerMiddleware Middleware
newtype SessionCookie = SessionCookie Cookie.SetCookie
newtype DBPoolIdleTime = DBPoolIdleTime NominalDiffTime
newtype DBPoolMaxConnections = DBPoolMaxConnections Int
newtype DatabaseUrl = DatabaseUrl ByteString
type ConfigBuilder = State.StateT TMap.TMap IO ()
newtype ExceptionTracker = ExceptionTracker { ExceptionTracker -> Maybe Request -> SomeException -> IO ()
onException :: Maybe Request -> SomeException -> IO () }
newtype IdeBaseUrl = IdeBaseUrl Text
newtype RLSAuthenticatedRole = RLSAuthenticatedRole Text
newtype AssetVersion = AssetVersion Text
newtype CustomMiddleware = CustomMiddleware Middleware
newtype DataSyncMaxSubscriptionsPerConnection = DataSyncMaxSubscriptionsPerConnection Int
newtype DataSyncMaxTransactionsPerConnection = DataSyncMaxTransactionsPerConnection Int
option :: forall option. Typeable option => option -> State.StateT TMap.TMap IO ()
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 TMap -> Bool
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 #-}
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 <- Typeable Environment => StateT TMap IO Environment
forall option. Typeable option => StateT TMap IO option
findOption @Environment
Logger
defaultLogger <- IO Logger -> StateT TMap IO Logger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Environment -> IO Logger
defaultLoggerForEnv Environment
environment)
Logger -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option Logger
defaultLogger
Logger
logger <- Typeable Logger => StateT TMap IO 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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 (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 { outputFormat :: OutputFormat
RequestLogger.outputFormat = IPAddrSource -> OutputFormat
RequestLogger.Apache IPAddrSource
requestLoggerIpAddrSource })
RequestLoggerMiddleware -> IO RequestLoggerMiddleware
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
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
20
(AppPort Int
port) <- Typeable AppPort => StateT TMap IO AppPort
forall option. Typeable option => StateT TMap IO option
findOption @AppPort
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) <- Typeable AppHostname => StateT TMap IO 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) <- Typeable BaseUrl => StateT TMap IO BaseUrl
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 k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINABLE ihpDefaultConfig #-}
env :: forall result monad. (MonadIO monad) => EnvVarReader result => ByteString -> monad result
env :: ByteString -> monad result
env ByteString
name = ByteString -> result -> monad result
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> result -> monad result
envOrDefault ByteString
name (Text -> result
forall a. Text -> a
error [i|Env var '#{name}' not set, but it's required for the app to run|])
envOrDefault :: (MonadIO monad) => EnvVarReader result => ByteString -> result -> monad result
envOrDefault :: ByteString -> result -> monad result
envOrDefault ByteString
name result
defaultValue = result -> Maybe result -> result
forall a. a -> Maybe a -> a
fromMaybe result
defaultValue (Maybe result -> result) -> monad (Maybe result) -> monad result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> monad (Maybe result)
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> monad (Maybe result)
envOrNothing ByteString
name
envOrNothing :: (MonadIO monad) => EnvVarReader result => ByteString -> monad (Maybe result)
envOrNothing :: ByteString -> monad (Maybe result)
envOrNothing ByteString
name = IO (Maybe result) -> monad (Maybe result)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe result) -> monad (Maybe result))
-> IO (Maybe result) -> monad (Maybe result)
forall a b. (a -> b) -> a -> b
$ (ByteString -> result) -> Maybe ByteString -> Maybe result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> result
parseString (Maybe ByteString -> Maybe result)
-> IO (Maybe ByteString) -> IO (Maybe result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (Maybe ByteString)
Posix.getEnv ByteString
name
where
parseString :: ByteString -> result
parseString ByteString
string = case ByteString -> Either Text result
forall valueType.
EnvVarReader valueType =>
ByteString -> Either Text valueType
envStringToValue ByteString
string of
Left Text
errorMessage -> Text -> result
forall a. Text -> a
error [i|Env var '#{name}' is invalid: #{errorMessage}|]
Right result
value -> result
value
class EnvVarReader valueType where
envStringToValue :: ByteString -> Either Text valueType
instance EnvVarReader Environment where
envStringToValue :: ByteString -> Either Text Environment
envStringToValue ByteString
"Production" = Environment -> Either Text Environment
forall a b. b -> Either a b
Right Environment
Production
envStringToValue ByteString
"Development" = Environment -> Either Text Environment
forall a b. b -> Either a b
Right Environment
Development
envStringToValue ByteString
otherwise = Text -> Either Text Environment
forall a b. a -> Either a b
Left Text
"Should be set to 'Development' or 'Production'"
instance EnvVarReader Int where
envStringToValue :: ByteString -> Either Text Int
envStringToValue ByteString
string = case Text -> Maybe Int
textToInt (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
string) of
Just Int
integer -> Int -> Either Text Int
forall a b. b -> Either a b
Right Int
integer
Maybe Int
Nothing -> Text -> Either Text Int
forall a b. a -> Either a b
Left [i|Expected integer, got #{string}|]
instance EnvVarReader Text where
envStringToValue :: ByteString -> Either Text Text
envStringToValue ByteString
string = Text -> Either Text Text
forall a b. b -> Either a b
Right (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
string)
instance EnvVarReader ByteString where
envStringToValue :: ByteString -> Either Text ByteString
envStringToValue ByteString
string = ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
string
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
ihpCloudContainerId <- ByteString -> StateT TMap IO (Maybe Text)
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> monad (Maybe result)
envOrNothing ByteString
"IHP_CLOUD_CONTAINER_ID"
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 = [ Maybe Text
ihpCloudContainerId, Maybe Text
ihpAssetVersion]
[Maybe Text] -> ([Maybe Text] -> [Text]) -> [Text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes
[Text] -> ([Text] -> Maybe Text) -> Maybe Text
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> [Text] -> Maybe Text
forall a. [a] -> Maybe a
head
Maybe Text -> (Maybe Text -> Text) -> Text
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"dev"
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 :: 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
<$> Typeable option => StateT TMap IO (Maybe option)
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 :: 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
|> Typeable option => TMap -> Maybe option
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 (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) <- Typeable AppHostname => StateT TMap IO AppHostname
forall option. Typeable option => StateT TMap IO option
findOption @AppHostname
Environment
environment <- Typeable Environment => StateT TMap IO Environment
forall option. Typeable option => StateT TMap IO option
findOption @Environment
(AppPort Int
appPort) <- Typeable AppPort => StateT TMap IO AppPort
forall option. Typeable option => StateT TMap IO option
findOption @AppPort
(BaseUrl Text
baseUrl) <- Typeable BaseUrl => StateT TMap IO BaseUrl
forall option. Typeable option => StateT TMap IO option
findOption @BaseUrl
(RequestLoggerMiddleware Middleware
requestLoggerMiddleware) <- Typeable RequestLoggerMiddleware =>
StateT TMap IO RequestLoggerMiddleware
forall option. Typeable option => StateT TMap IO option
findOption @RequestLoggerMiddleware
(SessionCookie SetCookie
sessionCookie) <- Typeable SessionCookie => StateT TMap IO SessionCookie
forall option. Typeable option => StateT TMap IO option
findOption @SessionCookie
MailServer
mailServer <- Typeable MailServer => StateT TMap IO MailServer
forall option. Typeable option => StateT TMap IO option
findOption @MailServer
(DBPoolIdleTime NominalDiffTime
dbPoolIdleTime) <- Typeable DBPoolIdleTime => StateT TMap IO DBPoolIdleTime
forall option. Typeable option => StateT TMap IO option
findOption @DBPoolIdleTime
(DBPoolMaxConnections Int
dbPoolMaxConnections) <- Typeable DBPoolMaxConnections =>
StateT TMap IO DBPoolMaxConnections
forall option. Typeable option => StateT TMap IO option
findOption @DBPoolMaxConnections
(DatabaseUrl ByteString
databaseUrl) <- Typeable DatabaseUrl => StateT TMap IO DatabaseUrl
forall option. Typeable option => StateT TMap IO option
findOption @DatabaseUrl
CSSFramework
cssFramework <- Typeable CSSFramework => StateT TMap IO CSSFramework
forall option. Typeable option => StateT TMap IO option
findOption @CSSFramework
Logger
logger <- Typeable Logger => StateT TMap IO Logger
forall option. Typeable option => StateT TMap IO option
findOption @Logger
ExceptionTracker
exceptionTracker <- Typeable ExceptionTracker => StateT TMap IO ExceptionTracker
forall option. Typeable option => StateT TMap IO option
findOption @ExceptionTracker
Maybe CorsResourcePolicy
corsResourcePolicy <- Typeable CorsResourcePolicy =>
StateT TMap IO (Maybe CorsResourcePolicy)
forall option. Typeable option => StateT TMap IO (Maybe option)
findOptionOrNothing @Cors.CorsResourcePolicy
ParseRequestBodyOptions
parseRequestBodyOptions <- Typeable ParseRequestBodyOptions =>
StateT TMap IO ParseRequestBodyOptions
forall option. Typeable option => StateT TMap IO option
findOption @WaiParse.ParseRequestBodyOptions
(IdeBaseUrl Text
ideBaseUrl) <- Typeable IdeBaseUrl => StateT TMap IO IdeBaseUrl
forall option. Typeable option => StateT TMap IO option
findOption @IdeBaseUrl
(RLSAuthenticatedRole Text
rlsAuthenticatedRole) <- Typeable RLSAuthenticatedRole =>
StateT TMap IO RLSAuthenticatedRole
forall option. Typeable option => StateT TMap IO option
findOption @RLSAuthenticatedRole
(AssetVersion Text
assetVersion) <- Typeable AssetVersion => StateT TMap IO AssetVersion
forall option. Typeable option => StateT TMap IO option
findOption @AssetVersion
CustomMiddleware
customMiddleware <- Typeable CustomMiddleware => StateT TMap IO CustomMiddleware
forall option. Typeable option => StateT TMap IO option
findOption @CustomMiddleware
TMap
appConfig <- StateT TMap IO TMap
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
FrameworkConfig -> StateT TMap IO FrameworkConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrameworkConfig :: Text
-> Environment
-> Int
-> Text
-> Middleware
-> SetCookie
-> MailServer
-> ByteString
-> NominalDiffTime
-> Int
-> CSSFramework
-> Logger
-> ExceptionTracker
-> TMap
-> Maybe CorsResourcePolicy
-> ParseRequestBodyOptions
-> Text
-> Text
-> Text
-> CustomMiddleware
-> FrameworkConfig
FrameworkConfig { Int
Maybe CorsResourcePolicy
ByteString
Text
NominalDiffTime
Logger
TMap
MailServer
ParseRequestBodyOptions
Environment
CSSFramework
SetCookie
CustomMiddleware
ExceptionTracker
Middleware
$sel:customMiddleware:FrameworkConfig :: CustomMiddleware
$sel:assetVersion:FrameworkConfig :: Text
$sel:rlsAuthenticatedRole:FrameworkConfig :: Text
$sel:ideBaseUrl:FrameworkConfig :: Text
$sel:parseRequestBodyOptions:FrameworkConfig :: ParseRequestBodyOptions
$sel:corsResourcePolicy:FrameworkConfig :: Maybe CorsResourcePolicy
$sel:appConfig:FrameworkConfig :: TMap
$sel:exceptionTracker:FrameworkConfig :: ExceptionTracker
$sel:logger:FrameworkConfig :: Logger
$sel:cssFramework:FrameworkConfig :: CSSFramework
$sel:dbPoolMaxConnections:FrameworkConfig :: Int
$sel:dbPoolIdleTime:FrameworkConfig :: NominalDiffTime
$sel:databaseUrl:FrameworkConfig :: ByteString
$sel:mailServer:FrameworkConfig :: MailServer
$sel:sessionCookie:FrameworkConfig :: SetCookie
$sel:requestLoggerMiddleware:FrameworkConfig :: Middleware
$sel:baseUrl:FrameworkConfig :: Text
$sel:appPort:FrameworkConfig :: Int
$sel:environment:FrameworkConfig :: Environment
$sel:appHostname:FrameworkConfig :: Text
appConfig :: TMap
customMiddleware :: CustomMiddleware
assetVersion :: Text
rlsAuthenticatedRole :: Text
ideBaseUrl :: Text
parseRequestBodyOptions :: ParseRequestBodyOptions
corsResourcePolicy :: Maybe CorsResourcePolicy
exceptionTracker :: ExceptionTracker
logger :: Logger
cssFramework :: CSSFramework
databaseUrl :: ByteString
dbPoolMaxConnections :: Int
dbPoolIdleTime :: NominalDiffTime
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT TMap IO FrameworkConfig
resolve) TMap
TMap.empty
FrameworkConfig -> IO FrameworkConfig
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
, FrameworkConfig -> Middleware
requestLoggerMiddleware :: !Middleware
, FrameworkConfig -> SetCookie
sessionCookie :: !Cookie.SetCookie
, FrameworkConfig -> MailServer
mailServer :: !MailServer
, FrameworkConfig -> ByteString
databaseUrl :: !ByteString
, FrameworkConfig -> NominalDiffTime
dbPoolIdleTime :: !NominalDiffTime
, FrameworkConfig -> Int
dbPoolMaxConnections :: !Int
, FrameworkConfig -> CSSFramework
cssFramework :: !CSSFramework
, FrameworkConfig -> Logger
logger :: !Logger
, FrameworkConfig -> ExceptionTracker
exceptionTracker :: !ExceptionTracker
, FrameworkConfig -> TMap
appConfig :: !TMap.TMap
, FrameworkConfig -> Maybe CorsResourcePolicy
corsResourcePolicy :: Maybe Cors.CorsResourcePolicy
, FrameworkConfig -> ParseRequestBodyOptions
parseRequestBodyOptions :: WaiParse.ParseRequestBodyOptions
, FrameworkConfig -> Text
ideBaseUrl :: Text
, FrameworkConfig -> Text
rlsAuthenticatedRole :: Text
, FrameworkConfig -> Text
assetVersion :: !Text
, FrameworkConfig -> CustomMiddleware
customMiddleware :: !CustomMiddleware
}
class ConfigProvider a where
getFrameworkConfig :: a -> FrameworkConfig
instance ConfigProvider FrameworkConfig where
getFrameworkConfig :: FrameworkConfig -> FrameworkConfig
getFrameworkConfig = FrameworkConfig -> FrameworkConfig
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
instance LoggingProvider FrameworkConfig where
getLogger :: FrameworkConfig -> Logger
getLogger = Proxy "logger" -> FrameworkConfig -> Logger
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "logger" (Proxy "logger")
Proxy "logger"
#logger
fromConfig :: (?context :: context, ConfigProvider context) => (FrameworkConfig -> a) -> a
fromConfig :: (FrameworkConfig -> a) -> a
fromConfig FrameworkConfig -> a
selector = (FrameworkConfig -> a
selector (FrameworkConfig -> a)
-> (context -> FrameworkConfig) -> context -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. context -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig) context
?context::context
?context
{-# INLINE fromConfig #-}
getConfig :: (?context :: context, ConfigProvider context) => FrameworkConfig
getConfig :: FrameworkConfig
getConfig = (FrameworkConfig -> FrameworkConfig) -> FrameworkConfig
forall context a.
(?context::context, ConfigProvider context) =>
(FrameworkConfig -> a) -> a
fromConfig FrameworkConfig -> FrameworkConfig
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINE getConfig #-}
defaultIHPSessionCookie :: Text -> Cookie.SetCookie
defaultIHPSessionCookie :: Text -> SetCookie
defaultIHPSessionCookie Text
baseUrl = SetCookie
forall a. Default a => a
def
{ setCookiePath :: Maybe ByteString
Cookie.setCookiePath = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/"
, setCookieMaxAge :: Maybe DiffTime
Cookie.setCookieMaxAge = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (Integer -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
30))
, setCookieSameSite :: Maybe SameSiteOption
Cookie.setCookieSameSite = SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
Cookie.sameSiteLax
, setCookieHttpOnly :: Bool
Cookie.setCookieHttpOnly = Bool
True
, setCookieSecure :: Bool
Cookie.setCookieSecure = Text
"https://" Text -> Text -> Bool
`Text.isPrefixOf` Text
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
/= :: RootApplication -> RootApplication -> Bool
$c/= :: RootApplication -> RootApplication -> Bool
== :: RootApplication -> RootApplication -> Bool
$c== :: 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
showList :: [RootApplication] -> ShowS
$cshowList :: [RootApplication] -> ShowS
show :: RootApplication -> String
$cshow :: RootApplication -> String
showsPrec :: Int -> RootApplication -> ShowS
$cshowsPrec :: Int -> RootApplication -> ShowS
Show)
defaultPort :: Int
defaultPort :: Int
defaultPort = Int
8000
defaultDatabaseUrl :: IO ByteString
defaultDatabaseUrl :: 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 :: Environment -> IO Logger
defaultLoggerForEnv :: Environment -> IO Logger
defaultLoggerForEnv = \case
Environment
Development -> IO Logger
defaultLogger
Environment
Production -> LoggerSettings -> IO Logger
newLogger LoggerSettings
forall a. Default a => a
def { $sel:level:LoggerSettings :: LogLevel
level = LogLevel
Info }
isEnvironment :: (?context :: context, ConfigProvider context) => Environment -> Bool
isEnvironment :: Environment -> Bool
isEnvironment Environment
environment = (context -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig context
?context::context
?context FrameworkConfig -> (FrameworkConfig -> Environment) -> Environment
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "environment" -> FrameworkConfig -> Environment
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "environment" (Proxy "environment")
Proxy "environment"
#environment) Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
environment
{-# INLINABLE isEnvironment #-}
isDevelopment :: (?context :: context, ConfigProvider context) => Bool
isDevelopment :: Bool
isDevelopment = Environment -> Bool
forall context.
(?context::context, ConfigProvider context) =>
Environment -> Bool
isEnvironment Environment
Development
{-# INLINABLE isDevelopment #-}
isProduction :: (?context :: context, ConfigProvider context) => Bool
isProduction :: 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
withFrameworkConfig :: ConfigBuilder -> (FrameworkConfig -> IO result) -> IO result
withFrameworkConfig :: 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 FrameworkConfig -> (FrameworkConfig -> Logger) -> Logger
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "logger" -> FrameworkConfig -> Logger
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "logger" (Proxy "logger")
Proxy "logger"
#logger Logger -> (Logger -> IO ()) -> IO ()
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "cleanup" -> Logger -> IO ()
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "cleanup" (Proxy "cleanup")
Proxy "cleanup"
#cleanup)
initModelContext :: FrameworkConfig -> IO ModelContext
initModelContext :: FrameworkConfig -> IO ModelContext
initModelContext FrameworkConfig { Environment
environment :: Environment
$sel:environment:FrameworkConfig :: FrameworkConfig -> Environment
environment, NominalDiffTime
dbPoolIdleTime :: NominalDiffTime
$sel:dbPoolIdleTime:FrameworkConfig :: FrameworkConfig -> NominalDiffTime
dbPoolIdleTime, Int
dbPoolMaxConnections :: Int
$sel:dbPoolMaxConnections:FrameworkConfig :: FrameworkConfig -> Int
dbPoolMaxConnections, ByteString
databaseUrl :: ByteString
$sel:databaseUrl:FrameworkConfig :: FrameworkConfig -> ByteString
databaseUrl, Logger
logger :: Logger
$sel:logger:FrameworkConfig :: FrameworkConfig -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext
modelContext