{-# LANGUAGE IncoherentInstances #-}
module IHP.Server (run, application) where
import IHP.Prelude
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai
import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)
import Network.Wai.Session (withSession, Session)
import Network.Wai.Session.ClientSession (clientsessionStore)
import qualified Web.ClientSession as ClientSession
import qualified Data.Vault.Lazy as Vault
import IHP.ApplicationContext
import qualified IHP.ControllerSupport as ControllerSupport
import qualified IHP.Environment as Env
import qualified IHP.PGListener as PGListener
import IHP.FrameworkConfig
import IHP.RouterSupport (frontControllerToWAIApp, FrontController, webSocketApp, webSocketAppWithCustomPath)
import IHP.ErrorController
import qualified IHP.AutoRefresh as AutoRefresh
import qualified IHP.AutoRefresh.Types as AutoRefresh
import IHP.LibDir
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 Control.Exception as Exception
import qualified System.Directory 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 IHP.Controller.NotFound (handleNotFound)
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
ModelContext
modelContext <- FrameworkConfig -> IO ModelContext
IHP.FrameworkConfig.initModelContext FrameworkConfig
frameworkConfig
let withPGListener :: (PGListener -> IO ()) -> IO ()
withPGListener = IO PGListener
-> (PGListener -> IO ()) -> (PGListener -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket (ModelContext -> IO PGListener
PGListener.init ModelContext
modelContext) PGListener -> IO ()
PGListener.stop
FrameworkConfig -> ModelContext -> IO () -> IO ()
withInitalizers FrameworkConfig
frameworkConfig ModelContext
modelContext do
(PGListener -> IO ()) -> IO ()
withPGListener \PGListener
pgListener -> do
Key (Session IO ByteString ByteString)
sessionVault <- IO (Key (Session IO ByteString ByteString))
forall a. IO (Key a)
Vault.newKey
IORef AutoRefreshServer
autoRefreshServer <- AutoRefreshServer -> IO (IORef AutoRefreshServer)
forall a. a -> IO (IORef a)
newIORef (PGListener -> AutoRefreshServer
AutoRefresh.newAutoRefreshServer PGListener
pgListener)
let ?modelContext = ?modelContext::ModelContext
ModelContext
modelContext
let ?applicationContext = ApplicationContext { $sel:modelContext:ApplicationContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext, $sel:session:ApplicationContext :: Key (Session IO ByteString ByteString)
session = Key (Session IO ByteString ByteString)
sessionVault, IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
$sel:autoRefreshServer:ApplicationContext :: IORef AutoRefreshServer
autoRefreshServer, FrameworkConfig
frameworkConfig :: FrameworkConfig
$sel:frameworkConfig:ApplicationContext :: FrameworkConfig
frameworkConfig, PGListener
pgListener :: PGListener
$sel:pgListener:ApplicationContext :: PGListener
pgListener }
Application -> Application
sessionMiddleware <- Key (Session IO ByteString ByteString)
-> FrameworkConfig -> IO (Application -> Application)
initSessionMiddleware Key (Session IO ByteString ByteString)
sessionVault FrameworkConfig
frameworkConfig
Application
staticApp <- FrameworkConfig -> IO Application
initStaticApp FrameworkConfig
frameworkConfig
let corsMiddleware :: Application -> Application
corsMiddleware = FrameworkConfig -> Application -> Application
initCorsMiddleware FrameworkConfig
frameworkConfig
let requestLoggerMiddleware :: Application -> Application
requestLoggerMiddleware = FrameworkConfig
frameworkConfig.requestLoggerMiddleware
let CustomMiddleware Application -> Application
customMiddleware = FrameworkConfig
frameworkConfig.customMiddleware
PGListener -> FrameworkConfig -> IO () -> IO ()
forall a.
(Worker RootApplication, ?modelContext::ModelContext) =>
PGListener -> FrameworkConfig -> IO a -> IO a
withBackgroundWorkers PGListener
pgListener FrameworkConfig
frameworkConfig
(IO () -> IO ()) -> (Application -> IO ()) -> Application -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (?applicationContext::ApplicationContext) =>
FrameworkConfig -> Application -> IO ()
FrameworkConfig -> Application -> IO ()
runServer FrameworkConfig
frameworkConfig
(Application -> IO ())
-> (Application -> Application) -> Application -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Application -> Application
customMiddleware
(Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Application -> Application
corsMiddleware
(Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Application -> Application
sessionMiddleware
(Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Application -> Application
requestLoggerMiddleware
(Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Application -> Application
methodOverridePost
(Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ (FrontController RootApplication,
?applicationContext::ApplicationContext) =>
Application -> Application
Application -> Application
application Application
staticApp
{-# INLINABLE run #-}
withBackgroundWorkers :: (Job.Worker RootApplication, ?modelContext :: ModelContext) => PGListener.PGListener -> FrameworkConfig -> IO a -> IO a
withBackgroundWorkers :: forall a.
(Worker RootApplication, ?modelContext::ModelContext) =>
PGListener -> FrameworkConfig -> IO a -> IO a
withBackgroundWorkers PGListener
pgListener FrameworkConfig
frameworkConfig IO a
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 () -> (Async () -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync ((?modelContext::ModelContext) =>
FrameworkConfig -> PGListener -> [JobWorker] -> IO ()
FrameworkConfig -> PGListener -> [JobWorker] -> IO ()
Job.devServerMainLoop FrameworkConfig
frameworkConfig PGListener
pgListener [JobWorker]
jobWorkers) (IO a -> Async () -> IO a
forall a b. a -> b -> a
const IO a
app)
else IO a
app
initStaticApp :: FrameworkConfig -> IO Application
initStaticApp :: FrameworkConfig -> IO Application
initStaticApp FrameworkConfig
frameworkConfig = do
FilePath
libDir <- Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> IO Text -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
findLibDirectory
let
maxAge :: MaxAge
maxAge = case FrameworkConfig
frameworkConfig.environment of
Environment
Env.Development -> Int -> MaxAge
Static.MaxAgeSeconds Int
0
Environment
Env.Production -> MaxAge
Static.MaxAgeForever
frameworkStaticDir :: FilePath
frameworkStaticDir = FilePath
libDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/static/"
frameworkSettings :: StaticSettings
frameworkSettings = (FilePath -> StaticSettings
Static.defaultWebAppSettings FilePath
frameworkStaticDir)
{ ss404Handler :: Maybe Application
Static.ss404Handler = Application -> Maybe Application
forall a. a -> Maybe a
Just Application
handleNotFound
, ssMaxAge :: MaxAge
Static.ssMaxAge = MaxAge
maxAge
}
appSettings :: StaticSettings
appSettings = (FilePath -> StaticSettings
Static.defaultWebAppSettings FilePath
"static/")
{ ss404Handler :: Maybe Application
Static.ss404Handler = Application -> Maybe Application
forall a. a -> Maybe a
Just (StaticSettings -> Application
Static.staticApp StaticSettings
frameworkSettings)
, ssMaxAge :: MaxAge
Static.ssMaxAge = MaxAge
maxAge
}
Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StaticSettings -> Application
Static.staticApp StaticSettings
appSettings)
initSessionMiddleware :: Vault.Key (Session IO ByteString ByteString) -> FrameworkConfig -> IO Middleware
initSessionMiddleware :: Key (Session IO ByteString ByteString)
-> FrameworkConfig -> IO (Application -> Application)
initSessionMiddleware Key (Session IO ByteString ByteString)
sessionVault FrameworkConfig { SetCookie
sessionCookie :: SetCookie
$sel:sessionCookie:FrameworkConfig :: FrameworkConfig -> SetCookie
sessionCookie } = do
let path :: FilePath
path = FilePath
"Config/client_session_key.aes"
Bool
hasSessionSecretEnvVar <- ByteString -> IO Bool
forall (monad :: * -> *). MonadIO monad => ByteString -> monad Bool
EnvVar.hasEnvVar ByteString
"IHP_SESSION_SECRET"
Bool
doesConfigDirectoryExist <- FilePath -> IO Bool
Directory.doesDirectoryExist FilePath
"Config"
SessionStore IO ByteString ByteString
store <- Key -> SessionStore IO ByteString ByteString
forall k v (m :: * -> *).
(Serialize k, Serialize v, Eq k, MonadIO m) =>
Key -> SessionStore m k v
clientsessionStore (Key -> SessionStore IO ByteString ByteString)
-> IO Key -> IO (SessionStore IO ByteString ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
if Bool
hasSessionSecretEnvVar Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
doesConfigDirectoryExist
then FilePath -> IO Key
ClientSession.getKeyEnv FilePath
"IHP_SESSION_SECRET"
else FilePath -> IO Key
ClientSession.getKey FilePath
path
let Application -> Application
sessionMiddleware :: Middleware = SessionStore IO ByteString ByteString
-> ByteString
-> SetCookie
-> Key (Session IO ByteString ByteString)
-> Application
-> Application
forall (m :: * -> *) k v.
SessionStore m k v
-> ByteString
-> SetCookie
-> Key (Session m k v)
-> Application
-> Application
withSession SessionStore IO ByteString ByteString
store ByteString
"SESSION" SetCookie
sessionCookie Key (Session IO ByteString ByteString)
sessionVault
(Application -> Application) -> IO (Application -> Application)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Application -> Application
sessionMiddleware
initCorsMiddleware :: FrameworkConfig -> Middleware
initCorsMiddleware :: FrameworkConfig -> Application -> Application
initCorsMiddleware FrameworkConfig { Maybe CorsResourcePolicy
corsResourcePolicy :: Maybe CorsResourcePolicy
$sel:corsResourcePolicy:FrameworkConfig :: FrameworkConfig -> Maybe CorsResourcePolicy
corsResourcePolicy } = case Maybe CorsResourcePolicy
corsResourcePolicy of
Just CorsResourcePolicy
corsResourcePolicy -> (Request -> Maybe CorsResourcePolicy) -> Application -> Application
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 -> Application -> Application
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
application :: (FrontController RootApplication, ?applicationContext :: ApplicationContext) => Application -> Application
application :: (FrontController RootApplication,
?applicationContext::ApplicationContext) =>
Application -> Application
application Application
staticApp Request
request Response -> IO ResponseReceived
respond = do
RequestContext
requestContext <- ApplicationContext
-> Request
-> (Response -> IO ResponseReceived)
-> IO RequestContext
ControllerSupport.createRequestContext ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext Request
request Response -> IO ResponseReceived
respond
let ?context = ?context::RequestContext
RequestContext
requestContext
let builtinControllers :: [RouteParser]
builtinControllers = let ?application = () in
[ forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
?application::application, ?applicationContext::ApplicationContext,
?context::RequestContext, Typeable application,
Typeable webSocketApp) =>
RouteParser
webSocketApp @AutoRefresh.AutoRefreshWSApp
, forall webSocketApp application.
(WSApp webSocketApp, InitControllerContext application,
?application::application, ?applicationContext::ApplicationContext,
?context::RequestContext, Typeable application,
Typeable webSocketApp) =>
ByteString -> RouteParser
webSocketAppWithCustomPath @AutoRefresh.AutoRefreshWSApp ByteString
""
]
RootApplication
-> [RouteParser] -> IO ResponseReceived -> IO ResponseReceived
forall app.
(?applicationContext::ApplicationContext, ?context::RequestContext,
FrontController app) =>
app -> [RouteParser] -> IO ResponseReceived -> IO ResponseReceived
frontControllerToWAIApp RootApplication
RootApplication [RouteParser]
builtinControllers (Application
staticApp Request
request Response -> IO ResponseReceived
respond)
{-# INLINABLE application #-}
runServer :: (?applicationContext :: ApplicationContext) => FrameworkConfig -> Application -> IO ()
runServer :: (?applicationContext::ApplicationContext) =>
FrameworkConfig -> Application -> IO ()
runServer config :: FrameworkConfig
config@FrameworkConfig { $sel:environment:FrameworkConfig :: FrameworkConfig -> Environment
environment = Environment
Env.Development, Int
appPort :: Int
$sel:appPort:FrameworkConfig :: FrameworkConfig -> Int
appPort } = Settings -> Application -> IO ()
Warp.runSettings (Settings -> Application -> IO ())
-> Settings -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$
Settings
Warp.defaultSettings
Settings -> (Settings -> Settings) -> Settings
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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 {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Int -> Settings -> Settings
Warp.setPort Int
appPort
runServer FrameworkConfig { $sel:environment:FrameworkConfig :: FrameworkConfig -> Environment
environment = Environment
Env.Production, Int
$sel:appPort:FrameworkConfig :: FrameworkConfig -> Int
appPort :: Int
appPort, ExceptionTracker
exceptionTracker :: ExceptionTracker
$sel:exceptionTracker:FrameworkConfig :: FrameworkConfig -> ExceptionTracker
exceptionTracker } = Settings -> Application -> IO ()
Warp.runSettings (Settings -> Application -> IO ())
-> Settings -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$
Settings
Warp.defaultSettings
Settings -> (Settings -> Settings) -> Settings
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Int -> Settings -> Settings
Warp.setPort Int
appPort
Settings -> (Settings -> Settings) -> Settings
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException ExceptionTracker
exceptionTracker.onException
instance ControllerSupport.InitControllerContext () where
initContext :: (?modelContext::ModelContext, ?requestContext::RequestContext,
?applicationContext::ApplicationContext,
?context::ControllerContext) =>
IO ()
initContext = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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 ()
$sel:onStartup:Initializer :: 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