{-# 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.Middleware.Static
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.ModelSupport
import IHP.ApplicationContext
import qualified IHP.ControllerSupport as ControllerSupport
import qualified IHP.Environment as Env
import IHP.Log.Types
import qualified IHP.PGListener as PGListener

import IHP.FrameworkConfig
import IHP.RouterSupport (frontControllerToWAIApp, FrontController, webSocketApp, webSocketAppWithCustomPath)
import qualified IHP.ErrorController as ErrorController
import Control.Exception (finally)
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 Control.Concurrent.Async as Async
import qualified Data.List as List
import qualified Data.ByteString.Char8 as ByteString
import qualified Network.Wai.Middleware.Cors as Cors
import qualified Control.Exception as Exception

import qualified System.Environment as Env
import qualified System.Directory as Directory
import qualified GHC.IO.Encoding as IO
import qualified System.IO as IO

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

    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 = 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

        (PGListener -> IO ()) -> IO ()
withPGListener \PGListener
pgListener -> do
            Key (Session IO ByteString ByteString)
sessionVault <- forall a. IO (Key a)
Vault.newKey

            IORef AutoRefreshServer
autoRefreshServer <- forall a. a -> IO (IORef a)
newIORef (PGListener -> AutoRefreshServer
AutoRefresh.newAutoRefreshServer PGListener
pgListener)

            let ?modelContext = ModelContext
modelContext
            let ?applicationContext = ApplicationContext { $sel:modelContext:ApplicationContext :: ModelContext
modelContext = ?modelContext::ModelContext
?modelContext, $sel:session:ApplicationContext :: Key (Session IO ByteString ByteString)
session = Key (Session IO ByteString ByteString)
sessionVault, IORef AutoRefreshServer
$sel:autoRefreshServer:ApplicationContext :: IORef AutoRefreshServer
autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer, FrameworkConfig
$sel:frameworkConfig:ApplicationContext :: FrameworkConfig
frameworkConfig :: FrameworkConfig
frameworkConfig, PGListener
$sel:pgListener:ApplicationContext :: PGListener
pgListener :: PGListener
pgListener }

            Application -> Application
sessionMiddleware <- Key (Session IO ByteString ByteString)
-> FrameworkConfig -> IO (Application -> Application)
initSessionMiddleware Key (Session IO ByteString ByteString)
sessionVault FrameworkConfig
frameworkConfig
            Application -> Application
staticMiddleware <- FrameworkConfig -> IO (Application -> Application)
initStaticMiddleware FrameworkConfig
frameworkConfig
            let corsMiddleware :: Application -> Application
corsMiddleware = FrameworkConfig -> Application -> Application
initCorsMiddleware FrameworkConfig
frameworkConfig
            let requestLoggerMiddleware :: Application -> Application
requestLoggerMiddleware = forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestLoggerMiddleware" a => a
#requestLoggerMiddleware FrameworkConfig
frameworkConfig
            let CustomMiddleware Application -> Application
customMiddleware = forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "customMiddleware" a => a
#customMiddleware FrameworkConfig
frameworkConfig

            forall a.
(Worker RootApplication, ?modelContext::ModelContext) =>
PGListener -> FrameworkConfig -> IO a -> IO a
withBackgroundWorkers PGListener
pgListener FrameworkConfig
frameworkConfig 
                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 ()
runServer FrameworkConfig
frameworkConfig
                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
                forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Application -> Application
staticMiddleware
                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
                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
                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
                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 
                forall a b. (a -> b) -> a -> b
$ (FrontController RootApplication,
 ?applicationContext::ApplicationContext) =>
Application
application

{-# 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 = forall application.
Worker application =>
application -> [JobWorker]
Job.workers RootApplication
RootApplication
    let isDevelopment :: Bool
isDevelopment = forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "environment" a => a
#environment FrameworkConfig
frameworkConfig forall a. Eq a => a -> a -> Bool
== Environment
Env.Development
    if Bool
isDevelopment Bool -> Bool -> Bool
&& Bool -> Bool
not (forall value. IsEmpty value => value -> Bool
isEmpty [JobWorker]
jobWorkers)
            then forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync ((?modelContext::ModelContext) =>
FrameworkConfig -> PGListener -> [JobWorker] -> IO ()
Job.devServerMainLoop FrameworkConfig
frameworkConfig PGListener
pgListener [JobWorker]
jobWorkers) (forall a b. a -> b -> a
const IO a
app)
            else IO a
app

-- | Returns a middleware that returns 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: If the files are stored in @static/vendor@/ we cache up to 30 days. For all other files we cache up to one day. It's best for vendor files to have e.g. the version as part of the file name. So @static/vendor/jquery.js@ should become @static/vendor/jquery-3.6.1.js@. That way when updating jquery you will have no issues with the cache.
-- - Static files in IHP's @static/@ directory can be cached up to 30 days
initStaticMiddleware :: FrameworkConfig -> IO Middleware
initStaticMiddleware :: FrameworkConfig -> IO (Application -> Application)
initStaticMiddleware FrameworkConfig { Environment
$sel:environment:FrameworkConfig :: FrameworkConfig -> Environment
environment :: Environment
environment } = do
        [Char]
libDirectory <- forall a b. ConvertibleStrings a b => a -> b
cs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
findLibDirectory

        -- We have different caching rules for the app `static/` directory and the IHP `static/` directory
        CacheContainer
appStaticCache <- CachingStrategy -> IO CacheContainer
initCaching ((FileMeta -> RequestHeaders) -> CachingStrategy
CustomCaching FileMeta -> RequestHeaders
getAppCacheHeader)
        CacheContainer
ihpStaticCache <- CachingStrategy -> IO CacheContainer
initCaching ((FileMeta -> RequestHeaders) -> CachingStrategy
CustomCaching forall {a}. IsString a => FileMeta -> [(a, ByteString)]
getIHPCacheHeader)
        let appCachingOptions :: Options
appCachingOptions = Options
defaultOptions { cacheContainer :: CacheContainer
cacheContainer = CacheContainer
appStaticCache }
        let ihpCachingOptions :: Options
ihpCachingOptions = Options
defaultOptions { cacheContainer :: CacheContainer
cacheContainer = CacheContainer
ihpStaticCache }

        let middleware :: Application -> Application
middleware =
                      Options -> Policy -> Application -> Application
staticPolicyWithOptions Options
appCachingOptions ([Char] -> Policy
addBase [Char]
"static/")
                    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Options -> Policy -> Application -> Application
staticPolicyWithOptions Options
ihpCachingOptions ([Char] -> Policy
addBase ([Char]
libDirectory forall a. Semigroup a => a -> a -> a
<> [Char]
"static/"))
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Application -> Application
middleware
    where
        -- In dev mode we disable the browser cache to make sure that always the latest CSS and JS is used
        -- In production mode we cache static assets up to one day
        getAppCacheHeader :: FileMeta -> RequestHeaders
getAppCacheHeader FileMeta
fileMeta =
            case Environment
environment of
                Environment
Env.Development -> [(HeaderName
"Cache-Control", ByteString
"no-cache,no-store,must-revalidate")]
                Environment
Env.Production ->
                    let
                        -- Cache file in `static/vendor` for one month. Code that is stored in `vendor` should
                        -- have the version number in it's file name. So `static/vendor/jquery.js` should become
                        -- `static/vendor/jquery-3.6.1.js`. That way when updating jquery you will have no issues
                        -- with the cache.
                        isVendorFile :: Bool
isVendorFile = [Char]
"static/vendor/" forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` (FileMeta -> [Char]
fm_fileName FileMeta
fileMeta)
                        vendorCacheControl :: (HeaderName, ByteString)
vendorCacheControl = (HeaderName
"Cache-Control", ByteString
"no-transform,public,max-age=2592000,s-maxage=2592000")
                        -- All other app files are cached for a day
                        appCacheControl :: (HeaderName, ByteString)
appCacheControl = (HeaderName
"Cache-Control", ByteString
"no-transform,public,max-age=86400,s-maxage=86400")
                    in
                        [ if Bool
isVendorFile then (HeaderName, ByteString)
vendorCacheControl else (HeaderName, ByteString)
appCacheControl
                        , (HeaderName
"Last-Modified", FileMeta -> ByteString
fm_lastModified FileMeta
fileMeta)
                        , (HeaderName
"ETag", FileMeta -> ByteString
fm_etag FileMeta
fileMeta)
                        , (HeaderName
"Vary", ByteString
"Accept-Encoding")
                        ]

        -- Files in IHP's own static directory are cached for one month
        getIHPCacheHeader :: FileMeta -> [(a, ByteString)]
getIHPCacheHeader FileMeta
fileMeta =
                    [ (a
"Cache-Control", ByteString
"no-transform,public,max-age=2592000,s-maxage=2592000")
                    , (a
"Last-Modified", FileMeta -> ByteString
fm_lastModified FileMeta
fileMeta)
                    , (a
"ETag", FileMeta -> ByteString
fm_etag FileMeta
fileMeta)
                    , (a
"Vary", ByteString
"Accept-Encoding")
                    ]

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
$sel:sessionCookie:FrameworkConfig :: FrameworkConfig -> SetCookie
sessionCookie :: SetCookie
sessionCookie } = do
    let path :: [Char]
path = [Char]
"Config/client_session_key.aes"

    Bool
hasSessionSecretEnvVar <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
Env.lookupEnv [Char]
"IHP_SESSION_SECRET"
    Bool
doesConfigDirectoryExist <- [Char] -> IO Bool
Directory.doesDirectoryExist [Char]
"Config"
    SessionStore IO ByteString ByteString
store <- forall k v (m :: * -> *).
(Serialize k, Serialize v, Eq k, MonadIO m) =>
Key -> SessionStore m k v
clientsessionStore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            if Bool
hasSessionSecretEnvVar Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
doesConfigDirectoryExist
                then [Char] -> IO Key
ClientSession.getKeyEnv [Char]
"IHP_SESSION_SECRET"
                else [Char] -> IO Key
ClientSession.getKey [Char]
path
    let Application -> Application
sessionMiddleware :: Middleware = 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Application -> Application
sessionMiddleware

initCorsMiddleware :: FrameworkConfig -> Middleware
initCorsMiddleware :: FrameworkConfig -> Application -> Application
initCorsMiddleware FrameworkConfig { Maybe CorsResourcePolicy
$sel:corsResourcePolicy:FrameworkConfig :: FrameworkConfig -> Maybe CorsResourcePolicy
corsResourcePolicy :: Maybe CorsResourcePolicy
corsResourcePolicy } = case Maybe CorsResourcePolicy
corsResourcePolicy of
        Just CorsResourcePolicy
corsResourcePolicy -> (Request -> Maybe CorsResourcePolicy) -> Application -> Application
Cors.cors (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just CorsResourcePolicy
corsResourcePolicy))
        Maybe CorsResourcePolicy
Nothing -> forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

application :: (FrontController RootApplication, ?applicationContext :: ApplicationContext) => Application
application :: (FrontController RootApplication,
 ?applicationContext::ApplicationContext) =>
Application
application Request
request Response -> IO ResponseReceived
respond = do
        RequestContext
requestContext <- ApplicationContext
-> Request
-> (Response -> IO ResponseReceived)
-> IO RequestContext
ControllerSupport.createRequestContext ?applicationContext::ApplicationContext
?applicationContext Request
request Response -> IO ResponseReceived
respond
        let ?context = RequestContext
requestContext
        let builtinControllers :: [RouteParser]
builtinControllers = let ?application = () in
                [ forall {k} webSocketApp application (controller :: k).
(WSApp webSocketApp, InitControllerContext application,
 ?application::application, ?applicationContext::ApplicationContext,
 ?context::RequestContext, Typeable application,
 Typeable webSocketApp) =>
RouteParser
webSocketApp @AutoRefresh.AutoRefreshWSApp
                , forall {k} webSocketApp application (controller :: k).
(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
                ]
        forall app.
(?applicationContext::ApplicationContext, ?context::RequestContext,
 FrontController app) =>
app -> [RouteParser] -> IO ResponseReceived -> IO ResponseReceived
frontControllerToWAIApp RootApplication
RootApplication [RouteParser]
builtinControllers (?context::RequestContext) => IO ResponseReceived
ErrorController.handleNotFound

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
$sel:appPort:FrameworkConfig :: FrameworkConfig -> Int
appPort :: Int
appPort } = Settings -> Application -> IO ()
Warp.runSettings forall a b. (a -> b) -> a -> b
$
                Settings
Warp.defaultSettings
                    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
                        )
                    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
appPort :: Int
$sel:appPort:FrameworkConfig :: FrameworkConfig -> Int
appPort, ExceptionTracker
$sel:exceptionTracker:FrameworkConfig :: FrameworkConfig -> ExceptionTracker
exceptionTracker :: ExceptionTracker
exceptionTracker } = Settings -> Application -> IO ()
Warp.runSettings forall a b. (a -> b) -> a -> b
$
                Settings
Warp.defaultSettings
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Int -> Settings -> Settings
Warp.setPort Int
appPort
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "onException" a => a
#onException ExceptionTracker
exceptionTracker)

instance ControllerSupport.InitControllerContext () where
    initContext :: (?modelContext::ModelContext, ?requestContext::RequestContext,
 ?applicationContext::ApplicationContext,
 ?context::ControllerContext) =>
IO ()
initContext = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()