{-# 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
    -- We cannot use 'Main.Utf8.withUtf8' here, as this for some reason breaks live reloading
    -- in the dev server. So we switch the file handles to utf8 manually
    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

-- | Returns a WAI app that servers files stored in the app's @static/@ directory and IHP's own @static/@  directory
--
-- HTTP Cache headers are set automatically. This includes Cache-Control, Last-Mofified and ETag
--
-- The cache strategy works like this:
-- - In dev mode we disable the browser cache for the app's @static/@ directory to make sure that always the latest CSS and JS is used
-- - In production mode: We cache files forever. IHP's 'assetPath' helper will add a hash to files to cache bust when something has changed.
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
"" -- For b.c. with older versions of ihp-auto-refresh.js
                ]

        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