{-# LANGUAGE IncoherentInstances #-}
module IHP.Server (run, application, initSessionMiddleware, initMiddlewareStack) where
import IHP.Prelude
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.Warp.Systemd as Systemd
import Network.Wai
import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)
import Network.Wai.Session (withSession)
import Network.Wai.Session.ClientSession (clientsessionStore)
import qualified Network.Wai.Middleware.HealthCheckEndpoint as HealthCheckEndpoint
import qualified Web.ClientSession as ClientSession
import IHP.Controller.Session (sessionVaultKey)
import qualified IHP.Environment as Env
import qualified IHP.PGListener as PGListener
import IHP.FrameworkConfig
import IHP.ModelSupport (withModelContext)
import IHP.RouterSupport (frontControllerToWAIApp, FrontController)
import IHP.AutoRefresh (AutoRefreshWSApp)
import qualified IHP.Job.Runner as Job
import qualified IHP.Job.Types as Job
import qualified Data.ByteString.Char8 as ByteString
import qualified Network.Wai.Middleware.Cors as Cors
import qualified Network.Wai.Middleware.Approot as Approot
import qualified Network.Wai.Middleware.AssetPath as AssetPath
import qualified System.Directory.OsPath as Directory
import qualified GHC.IO.Encoding as IO
import qualified System.IO as IO
import qualified Network.Wai.Application.Static as Static
import qualified WaiAppStatic.Types as Static
import qualified IHP.EnvVar as EnvVar
import qualified Network.Wreq as Wreq
import qualified Data.Function as Function
import IHP.RequestVault hiding (requestBodyMiddleware)
import IHP.Controller.Response (responseHeadersVaultKey)
import IHP.ControllerSupport (rlsContextVaultKey)
import IHP.PageHead.Types
import IHP.Modal.Types (modalContainerVaultKey)
import IHP.Controller.NotFound (handleNotFound)
import IHP.Static (staticRouteShortcut)
import Wai.Request.Params.Middleware (requestBodyMiddleware)
import Paths_ihp (getDataFileName)
import IHP.Controller.Layout (viewLayoutMiddleware)
import qualified Network.Socket as Socket
import qualified System.Environment as Env
import qualified Text.Read as Read
import qualified System.Posix.IO as Posix
import System.Posix.Types (Fd(..))
run :: (FrontController RootApplication, Job.Worker RootApplication) => ConfigBuilder -> IO ()
run :: (FrontController RootApplication, Worker RootApplication) =>
ConfigBuilder -> IO ()
run ConfigBuilder
configBuilder = do
TextEncoding -> IO ()
IO.setLocaleEncoding TextEncoding
IO.utf8
ConfigBuilder -> (FrameworkConfig -> IO ()) -> IO ()
forall result.
ConfigBuilder -> (FrameworkConfig -> IO result) -> IO result
withFrameworkConfig ConfigBuilder
configBuilder \FrameworkConfig
frameworkConfig -> do
ByteString -> Logger -> (ModelContext -> IO ()) -> IO ()
forall a. ByteString -> Logger -> (ModelContext -> IO a) -> IO a
withModelContext FrameworkConfig
frameworkConfig.databaseUrl FrameworkConfig
frameworkConfig.logger \ModelContext
modelContext -> do
FrameworkConfig -> ModelContext -> IO () -> IO ()
withInitalizers FrameworkConfig
frameworkConfig ModelContext
modelContext do
ByteString -> Logger -> (PGListener -> IO ()) -> IO ()
forall a. ByteString -> Logger -> (PGListener -> IO a) -> IO a
PGListener.withPGListener FrameworkConfig
frameworkConfig.databaseUrl FrameworkConfig
frameworkConfig.logger \PGListener
pgListener -> do
let ?modelContext = ?modelContext::ModelContext
ModelContext
modelContext
middleware <- FrameworkConfig
-> ModelContext
-> Maybe PGListener
-> IO
((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
initMiddlewareStack FrameworkConfig
frameworkConfig ModelContext
modelContext (PGListener -> Maybe PGListener
forall a. a -> Maybe a
Just PGListener
pgListener)
staticApp <- initStaticApp frameworkConfig
let requestLoggerMiddleware = FrameworkConfig
frameworkConfig.requestLoggerMiddleware
useSystemd <- EnvVar.envOrDefault "IHP_SYSTEMD" False
let fullApp = (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
middleware ((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ FrontController RootApplication =>
(Request -> Respond -> IO ResponseReceived)
-> ((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
(Request -> Respond -> IO ResponseReceived)
-> ((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
application Request -> Respond -> IO ResponseReceived
staticApp (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
requestLoggerMiddleware
let staticShortcut = (Request -> Respond -> IO ResponseReceived)
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
staticRouteShortcut Request -> Respond -> IO ResponseReceived
staticApp Request -> Respond -> IO ResponseReceived
fullApp
withBackgroundWorkers pgListener frameworkConfig
. runServer frameworkConfig useSystemd
. (if useSystemd then HealthCheckEndpoint.healthCheck else Function.id)
$ staticShortcut
{-# INLINABLE run #-}
withBackgroundWorkers :: (Job.Worker RootApplication, ?modelContext :: ModelContext) => PGListener.PGListener -> FrameworkConfig -> IO () -> IO ()
withBackgroundWorkers :: (Worker RootApplication, ?modelContext::ModelContext) =>
PGListener -> FrameworkConfig -> IO () -> IO ()
withBackgroundWorkers PGListener
pgListener FrameworkConfig
frameworkConfig IO ()
app = do
let jobWorkers :: [JobWorker]
jobWorkers = RootApplication -> [JobWorker]
forall application.
Worker application =>
application -> [JobWorker]
Job.workers RootApplication
RootApplication
let isDevelopment :: Bool
isDevelopment = FrameworkConfig
frameworkConfig.environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Env.Development
if Bool
isDevelopment Bool -> Bool -> Bool
&& Bool -> Bool
not ([JobWorker] -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty [JobWorker]
jobWorkers)
then IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ ((?modelContext::ModelContext) =>
FrameworkConfig -> PGListener -> [JobWorker] -> IO ()
FrameworkConfig -> PGListener -> [JobWorker] -> IO ()
Job.devServerMainLoop FrameworkConfig
frameworkConfig PGListener
pgListener [JobWorker]
jobWorkers) IO ()
app
else IO ()
app
initStaticApp :: FrameworkConfig -> IO Application
initStaticApp :: FrameworkConfig -> IO (Request -> Respond -> IO ResponseReceived)
initStaticApp FrameworkConfig
frameworkConfig = do
frameworkStaticDir <- do
ihpStaticOverride <- ByteString -> IO (Maybe String)
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> monad (Maybe result)
EnvVar.envOrNothing ByteString
"IHP_STATIC"
case ihpStaticOverride of
Just String
dir -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
dir
Maybe String
Nothing -> String -> IO String
getDataFileName String
"static"
appStaticDir <- EnvVar.envOrDefault "APP_STATIC" "static/"
let
maxAge = case FrameworkConfig
frameworkConfig.environment of
Environment
Env.Development -> Int -> MaxAge
Static.MaxAgeSeconds Int
0
Environment
Env.Production -> MaxAge
Static.MaxAgeForever
frameworkSettings = (String -> StaticSettings
Static.defaultWebAppSettings String
frameworkStaticDir)
{ Static.ss404Handler = Just (frameworkConfig.requestLoggerMiddleware handleNotFound)
, Static.ssMaxAge = maxAge
}
appSettings = (String -> StaticSettings
Static.defaultWebAppSettings String
appStaticDir)
{ Static.ss404Handler = Just (Static.staticApp frameworkSettings)
, Static.ssMaxAge = maxAge
}
pure (Static.staticApp appSettings)
initSessionMiddleware :: FrameworkConfig -> IO Middleware
initSessionMiddleware :: FrameworkConfig
-> IO
((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
initSessionMiddleware FrameworkConfig { SetCookie
sessionCookie :: SetCookie
sessionCookie :: FrameworkConfig -> SetCookie
sessionCookie } = do
let path :: String
path = String
"Config/client_session_key.aes"
hasSessionSecretEnvVar <- ByteString -> IO Bool
forall (monad :: * -> *). MonadIO monad => ByteString -> monad Bool
EnvVar.hasEnvVar ByteString
"IHP_SESSION_SECRET"
hasSessionSecretFileEnvVar <- EnvVar.hasEnvVar "IHP_SESSION_SECRET_FILE"
doesConfigDirectoryExist <- Directory.doesDirectoryExist "Config"
store <- clientsessionStore <$>
if hasSessionSecretFileEnvVar
then do
path <- EnvVar.env "IHP_SESSION_SECRET_FILE"
ClientSession.getKey path
else
if hasSessionSecretEnvVar || not doesConfigDirectoryExist
then ClientSession.getKeyEnv "IHP_SESSION_SECRET"
else ClientSession.getKey path
let sessionMiddleware :: Middleware = withSession store "SESSION" sessionCookie sessionVaultKey
pure sessionMiddleware
initCorsMiddleware :: FrameworkConfig -> Middleware
initCorsMiddleware :: FrameworkConfig
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
initCorsMiddleware FrameworkConfig { Maybe CorsResourcePolicy
corsResourcePolicy :: Maybe CorsResourcePolicy
corsResourcePolicy :: FrameworkConfig -> Maybe CorsResourcePolicy
corsResourcePolicy } = case Maybe CorsResourcePolicy
corsResourcePolicy of
Just CorsResourcePolicy
corsResourcePolicy -> (Request -> Maybe CorsResourcePolicy)
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
Cors.cors (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. a -> b -> a
const (CorsResourcePolicy -> Maybe CorsResourcePolicy
forall a. a -> Maybe a
Just CorsResourcePolicy
corsResourcePolicy))
Maybe CorsResourcePolicy
Nothing -> (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
initMiddlewareStack :: FrameworkConfig -> ModelContext -> Maybe PGListener.PGListener -> IO Middleware
initMiddlewareStack :: FrameworkConfig
-> ModelContext
-> Maybe PGListener
-> IO
((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
initMiddlewareStack FrameworkConfig
frameworkConfig ModelContext
modelContext Maybe PGListener
maybePgListener = do
sessionMiddleware <- FrameworkConfig
-> IO
((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
initSessionMiddleware FrameworkConfig
frameworkConfig
approotMiddleware <- Approot.envFallback
assetPathMiddleware <- AssetPath.assetPathFromEnvMiddleware "IHP_ASSET_VERSION" "IHP_ASSET_BASEURL"
let corsMiddleware = FrameworkConfig
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
initCorsMiddleware FrameworkConfig
frameworkConfig
let CustomMiddleware customMiddleware = frameworkConfig.customMiddleware
let pgListenerMw = ((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
-> (PGListener
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived)
-> Maybe PGListener
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id PGListener
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
pgListenerMiddleware Maybe PGListener
maybePgListener
let responseHeadersMiddleware = Key (IORef [Header])
-> [Header]
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
forall value.
Key (IORef value)
-> value
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
insertNewIORefVaultMiddleware Key (IORef [Header])
responseHeadersVaultKey []
let rlsContextMiddleware = Key (IORef (Maybe RowLevelSecurityContext))
-> Maybe RowLevelSecurityContext
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
forall value.
Key (IORef value)
-> value
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
insertNewIORefVaultMiddleware Key (IORef (Maybe RowLevelSecurityContext))
rlsContextVaultKey Maybe RowLevelSecurityContext
forall a. Maybe a
Nothing
let modalMiddleware = Key (IORef (Maybe ModalContainer))
-> Maybe ModalContainer
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
forall value.
Key (IORef value)
-> value
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
insertNewIORefVaultMiddleware Key (IORef (Maybe ModalContainer))
modalContainerVaultKey Maybe ModalContainer
forall a. Maybe a
Nothing
let pageHeadMiddleware = Key (IORef PageHeadState)
-> PageHeadState
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
forall value.
Key (IORef value)
-> value
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
insertNewIORefVaultMiddleware Key (IORef PageHeadState)
pageHeadVaultKey PageHeadState
emptyPageHeadState
pure $
customMiddleware
. corsMiddleware
. methodOverridePost
. sessionMiddleware
. approotMiddleware
. viewLayoutMiddleware
. responseHeadersMiddleware
. rlsContextMiddleware
. pageHeadMiddleware
. modalMiddleware
. modelContextMiddleware modelContext
. frameworkConfigMiddleware frameworkConfig
. requestBodyMiddleware frameworkConfig.parseRequestBodyOptions
. pgListenerMw
. assetPathMiddleware
application :: (FrontController RootApplication) => Application -> Middleware -> Application
application :: FrontController RootApplication =>
(Request -> Respond -> IO ResponseReceived)
-> ((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
application Request -> Respond -> IO ResponseReceived
staticApp (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
middleware Request
request Respond
respond = do
forall app autoRefreshApp.
(FrontController app, WSApp autoRefreshApp,
Typeable autoRefreshApp, InitControllerContext ()) =>
((Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived)
-> app
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
frontControllerToWAIApp @RootApplication @AutoRefreshWSApp (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
middleware RootApplication
RootApplication Request -> Respond -> IO ResponseReceived
staticApp Request
request Respond
respond
{-# INLINABLE application #-}
runServer :: FrameworkConfig -> Bool -> Application -> IO ()
runServer :: FrameworkConfig
-> Bool -> (Request -> Respond -> IO ResponseReceived) -> IO ()
runServer config :: FrameworkConfig
config@FrameworkConfig { environment :: FrameworkConfig -> Environment
environment = Environment
Env.Development, Int
appPort :: Int
appPort :: FrameworkConfig -> Int
appPort } Bool
useSystemd = \Request -> Respond -> IO ResponseReceived
app -> do
let warpSettings :: Settings
warpSettings = Settings
Warp.defaultSettings
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
|> IO () -> Settings -> Settings
Warp.setBeforeMainLoop (do
ByteString -> IO ()
ByteString.putStrLn ByteString
"Server started"
Handle -> IO ()
IO.hFlush Handle
IO.stdout
)
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
|> Int -> Settings -> Settings
Warp.setPort Int
appPort
socketFdEnv <- String -> IO (Maybe String)
Env.lookupEnv String
"IHP_SOCKET_FD"
case socketFdEnv of
Just String
fdStr | Just Int
fd <- String -> Maybe Int
forall a. Read a => String -> Maybe a
Read.readMaybe String
fdStr -> do
dupFd <- Fd -> IO Fd
Posix.dup (CInt -> Fd
Fd (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
fd :: Int)))
socket <- Socket.mkSocket (fromIntegral dupFd)
Warp.runSettingsSocket warpSettings socket app
Maybe String
_ ->
Settings -> (Request -> Respond -> IO ResponseReceived) -> IO ()
Warp.runSettings Settings
warpSettings Request -> Respond -> IO ResponseReceived
app
runServer FrameworkConfig { environment :: FrameworkConfig -> Environment
environment = Environment
Env.Production, Int
appPort :: FrameworkConfig -> Int
appPort :: Int
appPort, ExceptionTracker
exceptionTracker :: ExceptionTracker
exceptionTracker :: FrameworkConfig -> ExceptionTracker
exceptionTracker } Bool
useSystemd =
let
warpSettings :: Settings
warpSettings = Settings
Warp.defaultSettings
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
|> Int -> Settings -> Settings
Warp.setPort Int
appPort
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
|> (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException ExceptionTracker
exceptionTracker.onException
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
|> Maybe Int -> Settings -> Settings
Warp.setGracefulShutdownTimeout (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
6)
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
|> Int -> Settings -> Settings
Warp.setFdCacheDuration (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60)
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
|> Int -> Settings -> Settings
Warp.setFileInfoCacheDuration (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60)
heartbeatCheck :: IO ()
heartbeatCheck = do
response <- String -> IO (Response ByteString)
Wreq.get (String
"http://127.0.0.1:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Int -> Text
forall a. Show a => a -> Text
show Int
appPort) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/_healthz")
pure ()
systemdSettings :: SystemdSettings
systemdSettings = SystemdSettings
Systemd.defaultSystemdSettings
SystemdSettings
-> (SystemdSettings -> SystemdSettings) -> SystemdSettings
forall a b. a -> (a -> b) -> b
|> Bool -> SystemdSettings -> SystemdSettings
Systemd.setRequireSocketActivation Bool
True
SystemdSettings
-> (SystemdSettings -> SystemdSettings) -> SystemdSettings
forall a b. a -> (a -> b) -> b
|> Maybe Int -> SystemdSettings -> SystemdSettings
Systemd.setHeartbeatInterval (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
30)
SystemdSettings
-> (SystemdSettings -> SystemdSettings) -> SystemdSettings
forall a b. a -> (a -> b) -> b
|> IO () -> SystemdSettings -> SystemdSettings
Systemd.setHeartbeatCheck IO ()
heartbeatCheck
in
if Bool
useSystemd
then SystemdSettings
-> Settings -> (Request -> Respond -> IO ResponseReceived) -> IO ()
Systemd.runSystemdWarp SystemdSettings
systemdSettings Settings
warpSettings
else Settings -> (Request -> Respond -> IO ResponseReceived) -> IO ()
Warp.runSettings Settings
warpSettings
withInitalizers :: FrameworkConfig -> ModelContext -> IO () -> IO ()
withInitalizers :: FrameworkConfig -> ModelContext -> IO () -> IO ()
withInitalizers FrameworkConfig
frameworkConfig ModelContext
modelContext IO ()
continue = do
let ?context = ?context::FrameworkConfig
FrameworkConfig
frameworkConfig
let ?modelContext = ?modelContext::ModelContext
ModelContext
modelContext
(?context::FrameworkConfig, ?modelContext::ModelContext) =>
[Initializer] -> IO ()
[Initializer] -> IO ()
withInitalizers' FrameworkConfig
frameworkConfig.initializers
where
withInitalizers' :: (?context :: FrameworkConfig, ?modelContext :: ModelContext) => [Initializer] -> IO ()
withInitalizers' :: (?context::FrameworkConfig, ?modelContext::ModelContext) =>
[Initializer] -> IO ()
withInitalizers' (Initializer { (?context::FrameworkConfig, ?modelContext::ModelContext) => IO ()
onStartup :: (?context::FrameworkConfig, ?modelContext::ModelContext) => IO ()
onStartup :: Initializer
-> (?context::FrameworkConfig, ?modelContext::ModelContext) =>
IO ()
onStartup } : [Initializer]
rest) = IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
(?context::FrameworkConfig, ?modelContext::ModelContext) => IO ()
onStartup (\Async ()
async -> Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
async IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (?context::FrameworkConfig, ?modelContext::ModelContext) =>
[Initializer] -> IO ()
[Initializer] -> IO ()
withInitalizers' [Initializer]
rest)
withInitalizers' [] = IO ()
continue