{-# 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)
import Network.Wai.Session.ClientSession (clientsessionStore)
import qualified Web.ClientSession as ClientSession
import IHP.Controller.Session (sessionVaultKey)
import IHP.ApplicationContext
import qualified IHP.Environment as Env
import qualified IHP.PGListener as PGListener

import IHP.FrameworkConfig
import IHP.RouterSupport (frontControllerToWAIApp, FrontController)
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
                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 { modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext, IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer, FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig, PGListener
pgListener :: PGListener
pgListener :: PGListener
pgListener }

                (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
sessionMiddleware <- FrameworkConfig
-> IO
     ((Request -> Respond -> IO ResponseReceived)
      -> Request -> Respond -> IO ResponseReceived)
initSessionMiddleware FrameworkConfig
frameworkConfig
                Request -> Respond -> IO ResponseReceived
staticApp <- FrameworkConfig -> IO (Request -> Respond -> IO ResponseReceived)
initStaticApp FrameworkConfig
frameworkConfig
                let corsMiddleware :: (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
corsMiddleware = FrameworkConfig
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
initCorsMiddleware FrameworkConfig
frameworkConfig
                let requestLoggerMiddleware :: (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
requestLoggerMiddleware = FrameworkConfig
frameworkConfig.requestLoggerMiddleware
                let CustomMiddleware (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
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 ())
-> ((Request -> Respond -> IO ResponseReceived) -> IO ())
-> (Request -> Respond -> IO ResponseReceived)
-> 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
-> (Request -> Respond -> IO ResponseReceived) -> IO ()
FrameworkConfig
-> (Request -> Respond -> IO ResponseReceived) -> IO ()
runServer FrameworkConfig
frameworkConfig
                    ((Request -> Respond -> IO ResponseReceived) -> IO ())
-> ((Request -> Respond -> IO ResponseReceived)
    -> Request -> Respond -> IO ResponseReceived)
-> (Request -> Respond -> IO ResponseReceived)
-> 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
. (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
customMiddleware
                    ((Request -> Respond -> IO ResponseReceived)
 -> Request -> Respond -> IO ResponseReceived)
-> ((Request -> Respond -> IO ResponseReceived)
    -> Request -> Respond -> IO ResponseReceived)
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
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
. (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
corsMiddleware
                    ((Request -> Respond -> IO ResponseReceived)
 -> Request -> Respond -> IO ResponseReceived)
-> ((Request -> Respond -> IO ResponseReceived)
    -> Request -> Respond -> IO ResponseReceived)
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
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
. (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
methodOverridePost
                    ((Request -> Respond -> IO ResponseReceived)
 -> Request -> Respond -> IO ResponseReceived)
-> ((Request -> Respond -> IO ResponseReceived)
    -> Request -> Respond -> IO ResponseReceived)
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
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
. (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
sessionMiddleware
                    ((Request -> Respond -> IO ResponseReceived) -> IO ())
-> (Request -> Respond -> IO ResponseReceived) -> IO ()
forall a b. (a -> b) -> a -> b
$ (FrontController RootApplication,
 ?applicationContext::ApplicationContext) =>
(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

{-# 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 (Request -> Respond -> IO ResponseReceived)
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
    Maybe FilePath
ihpStatic <- ByteString -> IO (Maybe FilePath)
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> monad (Maybe result)
EnvVar.envOrNothing ByteString
"IHP_STATIC"

    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 -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath
libDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/static/") Maybe FilePath
ihpStatic
        frameworkSettings :: StaticSettings
frameworkSettings = (FilePath -> StaticSettings
Static.defaultWebAppSettings FilePath
frameworkStaticDir)
                { Static.ss404Handler = Just (frameworkConfig.requestLoggerMiddleware handleNotFound)
                , Static.ssMaxAge = maxAge
                }
        appSettings :: StaticSettings
appSettings = (FilePath -> StaticSettings
Static.defaultWebAppSettings FilePath
"static/")
                { Static.ss404Handler = Just (Static.staticApp frameworkSettings)
                , Static.ssMaxAge = maxAge
                }

    (Request -> Respond -> IO ResponseReceived)
-> IO (Request -> Respond -> IO ResponseReceived)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StaticSettings -> Request -> Respond -> IO ResponseReceived
Static.staticApp StaticSettings
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 :: 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 (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
sessionMiddleware :: Middleware = SessionStore IO ByteString ByteString
-> ByteString
-> SetCookie
-> Key (Session IO ByteString ByteString)
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
forall (m :: * -> *) k v.
SessionStore m k v
-> ByteString
-> SetCookie
-> Key (Session m k v)
-> (Request -> Respond -> IO ResponseReceived)
-> Request
-> Respond
-> IO ResponseReceived
withSession SessionStore IO ByteString ByteString
store ByteString
"SESSION" SetCookie
sessionCookie Key (Session IO ByteString ByteString)
sessionVaultKey
    ((Request -> Respond -> IO ResponseReceived)
 -> Request -> Respond -> IO ResponseReceived)
-> IO
     ((Request -> Respond -> IO ResponseReceived)
      -> Request -> Respond -> IO ResponseReceived)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
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

application :: (FrontController RootApplication, ?applicationContext :: ApplicationContext) => Application -> Middleware -> Application
application :: (FrontController RootApplication,
 ?applicationContext::ApplicationContext) =>
(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.
(?applicationContext::ApplicationContext, 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 @AutoRefresh.AutoRefreshWSApp (Request -> Respond -> IO ResponseReceived)
-> Request -> Respond -> IO ResponseReceived
middleware RootApplication
RootApplication Request -> Respond -> IO ResponseReceived
staticApp Request
request Respond
respond
{-# INLINABLE application #-}

runServer :: (?applicationContext :: ApplicationContext) => FrameworkConfig -> Application -> IO ()
runServer :: (?applicationContext::ApplicationContext) =>
FrameworkConfig
-> (Request -> Respond -> IO ResponseReceived) -> IO ()
runServer config :: FrameworkConfig
config@FrameworkConfig { environment :: FrameworkConfig -> Environment
environment = Environment
Env.Development, Int
appPort :: Int
appPort :: FrameworkConfig -> Int
appPort } = Settings -> (Request -> Respond -> IO ResponseReceived) -> IO ()
Warp.runSettings (Settings -> (Request -> Respond -> IO ResponseReceived) -> IO ())
-> Settings -> (Request -> Respond -> IO ResponseReceived) -> 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 { environment :: FrameworkConfig -> Environment
environment = Environment
Env.Production, Int
appPort :: FrameworkConfig -> Int
appPort :: Int
appPort, ExceptionTracker
exceptionTracker :: ExceptionTracker
exceptionTracker :: FrameworkConfig -> ExceptionTracker
exceptionTracker } = Settings -> (Request -> Respond -> IO ResponseReceived) -> IO ()
Warp.runSettings (Settings -> (Request -> Respond -> IO ResponseReceived) -> IO ())
-> Settings -> (Request -> Respond -> IO ResponseReceived) -> 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

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