module IHP.FrameworkConfig where

import IHP.Prelude
import ClassyPrelude (readMay)
import qualified System.Environment as Environment
import System.Directory (getCurrentDirectory)
import IHP.Environment
import Data.String.Conversions (cs)
import qualified System.Directory as Directory
import qualified Data.Text as Text
import qualified System.Process as Process
import Network.Wai (Middleware)
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Web.Cookie as Cookie
import Data.Default (def)
import Data.Time.Clock (NominalDiffTime)
import IHP.Mail.Types
import qualified Control.Monad.Trans.State.Strict as State
import Data.Maybe (fromJust)
import qualified Data.TMap as TMap
import qualified Data.Typeable as Typeable
import IHP.HaskellSupport hiding (set)
import IHP.View.Types
import IHP.View.CSSFramework
import System.IO.Unsafe (unsafePerformIO)
import IHP.Log.Types
import IHP.Log (makeRequestLogger, defaultRequestLogger)
import Network.Wai
import qualified Network.Wai.Handler.Warp as Warp

newtype AppHostname = AppHostname Text
newtype AppPort = AppPort Int
newtype BaseUrl = BaseUrl Text

-- | Provides IHP with a middleware to log requests and responses.
--
-- By default this uses the RequestLogger middleware from wai-extra. Take a look at the wai-extra
-- documentation when you want to customize the request logging.
--
-- See https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html
--
--
-- Set @requestLoggerMiddleware = \application -> application@ to disable request logging.
newtype RequestLoggerMiddleware = RequestLoggerMiddleware Middleware

-- | Provides the default settings for the session cookie.
--
-- - Max Age: 30 days
-- - Same Site Policy: Lax
-- - HttpOnly (no access through JS)
-- - secure, when baseUrl is a https url
--
-- Override this to set e.g. a custom max age or change the default same site policy.
--
-- __Example: Set max age to 90 days__
-- > sessionCookie = defaultIHPSessionCookie { Cookie.setCookieMaxAge = Just (fromIntegral (60 * 60 * 24 * 90)) }
newtype SessionCookie = SessionCookie Cookie.SetCookie

-- | How long db connection are kept alive inside the connecton pool when they're idle
newtype DBPoolIdleTime = DBPoolIdleTime NominalDiffTime

-- | Max number of db connections the connection pool can open to the database
newtype DBPoolMaxConnections = DBPoolMaxConnections Int

newtype DatabaseUrl = DatabaseUrl ByteString

type ConfigBuilder = State.StateT TMap.TMap IO ()

-- | Interface for exception tracking services such as sentry
newtype ExceptionTracker = ExceptionTracker { ExceptionTracker -> Maybe Request -> SomeException -> IO ()
onException :: Maybe Request -> SomeException -> IO () }

-- | Puts an option into the current configuration
--
-- In case an option already exists with the same type, it will not be overriden:
--
-- > option Production
-- > option Development
-- > findOption @Environment
--
-- This code will return 'Production' as the second call to 'option' is ignored to not override the existing option.
option :: forall option. Typeable option => option -> State.StateT TMap.TMap IO ()
option :: option -> StateT TMap IO ()
option option
value = (TMap -> TMap) -> StateT TMap IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\TMap
map -> if TMap -> Bool
forall a. Typeable a => TMap -> Bool
TMap.member @option TMap
map then TMap
map else option -> TMap -> TMap
forall a. Typeable a => a -> TMap -> TMap
TMap.insert option
value TMap
map)
{-# INLINABLE option #-}

ihpDefaultConfig :: ConfigBuilder
ihpDefaultConfig :: StateT TMap IO ()
ihpDefaultConfig = do
    Environment -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option Environment
Development
    AppHostname -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (AppHostname -> StateT TMap IO ())
-> AppHostname -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Text -> AppHostname
AppHostname Text
"localhost"

    Int
port <- IO Int -> StateT TMap IO Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
defaultAppPort
    AppPort -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (AppPort -> StateT TMap IO ()) -> AppPort -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Int -> AppPort
AppPort Int
port

    ExceptionTracker -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (ExceptionTracker -> StateT TMap IO ())
-> ExceptionTracker -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe Request -> SomeException -> IO ()) -> ExceptionTracker
ExceptionTracker Maybe Request -> SomeException -> IO ()
Warp.defaultOnException

    Environment
environment <- Typeable Environment => StateT TMap IO Environment
forall option. Typeable option => StateT TMap IO option
findOption @Environment

    Logger
defaultLogger <- IO Logger -> StateT TMap IO Logger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Environment -> IO Logger
defaultLoggerForEnv Environment
environment)
    Logger -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option Logger
defaultLogger
    Logger
logger <- Typeable Logger => StateT TMap IO Logger
forall option. Typeable option => StateT TMap IO option
findOption @Logger

    IPAddrSource
requestLoggerIpAddrSource <-
        IO (Maybe String) -> StateT TMap IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
Environment.lookupEnv String
"IHP_REQUEST_LOGGER_IP_ADDR_SOURCE")
        StateT TMap IO (Maybe String)
-> (Maybe String -> StateT TMap IO IPAddrSource)
-> StateT TMap IO IPAddrSource
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just String
"FromHeader" -> IPAddrSource -> StateT TMap IO IPAddrSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPAddrSource
RequestLogger.FromHeader
            Just String
"FromSocket" -> IPAddrSource -> StateT TMap IO IPAddrSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPAddrSource
RequestLogger.FromSocket
            Maybe String
Nothing           -> IPAddrSource -> StateT TMap IO IPAddrSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPAddrSource
RequestLogger.FromSocket
            Maybe String
_                 -> Text -> StateT TMap IO IPAddrSource
forall a. Text -> a
error Text
"IHP_REQUEST_LOGGER_IP_ADDR_SOURCE set to invalid value. Expected FromHeader or FromSocket"

    RequestLoggerMiddleware -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (RequestLoggerMiddleware -> StateT TMap IO ())
-> RequestLoggerMiddleware -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Middleware -> RequestLoggerMiddleware
RequestLoggerMiddleware (Middleware -> RequestLoggerMiddleware)
-> Middleware -> RequestLoggerMiddleware
forall a b. (a -> b) -> a -> b
$
            case Environment
environment of
                Environment
Development -> Logger
logger Logger -> (Logger -> Middleware) -> Middleware
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Logger -> Middleware
defaultRequestLogger
                Environment
Production  -> Logger
logger Logger -> (Logger -> Middleware) -> Middleware
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> RequestLoggerSettings -> Logger -> Middleware
makeRequestLogger RequestLoggerSettings
forall a. Default a => a
def { outputFormat :: OutputFormat
RequestLogger.outputFormat = IPAddrSource -> OutputFormat
RequestLogger.Apache IPAddrSource
requestLoggerIpAddrSource }

    MailServer -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (MailServer -> StateT TMap IO ())
-> MailServer -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ MailServer
Sendmail

    ByteString
databaseUrl <- IO ByteString -> StateT TMap IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
defaultDatabaseUrl

    DatabaseUrl -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (DatabaseUrl -> StateT TMap IO ())
-> DatabaseUrl -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> DatabaseUrl
DatabaseUrl ByteString
databaseUrl
    DBPoolIdleTime -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (DBPoolIdleTime -> StateT TMap IO ())
-> DBPoolIdleTime -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DBPoolIdleTime
DBPoolIdleTime (NominalDiffTime -> DBPoolIdleTime)
-> NominalDiffTime -> DBPoolIdleTime
forall a b. (a -> b) -> a -> b
$
            case Environment
environment of
            Environment
Development -> NominalDiffTime
2
            Environment
Production -> NominalDiffTime
60
    DBPoolMaxConnections -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (DBPoolMaxConnections -> StateT TMap IO ())
-> DBPoolMaxConnections -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Int -> DBPoolMaxConnections
DBPoolMaxConnections Int
20

    (AppPort Int
port) <- Typeable AppPort => StateT TMap IO AppPort
forall option. Typeable option => StateT TMap IO option
findOption @AppPort
    (AppHostname Text
appHostname) <- Typeable AppHostname => StateT TMap IO AppHostname
forall option. Typeable option => StateT TMap IO option
findOption @AppHostname
    BaseUrl -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (BaseUrl -> StateT TMap IO ()) -> BaseUrl -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseUrl
BaseUrl (Text
"http://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
appHostname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
80 then Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
port else Text
""))

    (BaseUrl Text
currentBaseUrl) <- Typeable BaseUrl => StateT TMap IO BaseUrl
forall option. Typeable option => StateT TMap IO option
findOption @BaseUrl
    SessionCookie -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option (SessionCookie -> StateT TMap IO ())
-> SessionCookie -> StateT TMap IO ()
forall a b. (a -> b) -> a -> b
$ SetCookie -> SessionCookie
SessionCookie (Text -> SetCookie
defaultIHPSessionCookie Text
currentBaseUrl)

    CSSFramework -> StateT TMap IO ()
forall option. Typeable option => option -> StateT TMap IO ()
option CSSFramework
bootstrap


{-# INLINABLE ihpDefaultConfig #-}

findOption :: forall option. Typeable option => State.StateT TMap.TMap IO option
findOption :: StateT TMap IO option
findOption = do
    TMap
options <- StateT TMap IO TMap
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
    TMap
options
        TMap -> (TMap -> Maybe option) -> Maybe option
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Typeable option => TMap -> Maybe option
forall a. Typeable a => TMap -> Maybe a
TMap.lookup @option
        Maybe option -> (Maybe option -> option) -> option
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> option -> Maybe option -> option
forall a. a -> Maybe a -> a
fromMaybe (Text -> option
forall a. Text -> a
error (Text -> option) -> Text -> option
forall a b. (a -> b) -> a -> b
$ Text
"Could not find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a. Show a => a -> Text
show (option -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf (option
forall a. HasCallStack => a
undefined :: option)))
        option
-> (option -> StateT TMap IO option) -> StateT TMap IO option
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> option -> StateT TMap IO option
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINABLE findOption #-}

buildFrameworkConfig :: ConfigBuilder -> IO FrameworkConfig
buildFrameworkConfig :: StateT TMap IO () -> IO FrameworkConfig
buildFrameworkConfig StateT TMap IO ()
appConfig = do
    let resolve :: StateT TMap IO FrameworkConfig
resolve = do
            (AppHostname Text
appHostname) <- Typeable AppHostname => StateT TMap IO AppHostname
forall option. Typeable option => StateT TMap IO option
findOption @AppHostname
            Environment
environment <- Typeable Environment => StateT TMap IO Environment
forall option. Typeable option => StateT TMap IO option
findOption @Environment
            (AppPort Int
appPort) <- Typeable AppPort => StateT TMap IO AppPort
forall option. Typeable option => StateT TMap IO option
findOption @AppPort
            (BaseUrl Text
baseUrl) <- Typeable BaseUrl => StateT TMap IO BaseUrl
forall option. Typeable option => StateT TMap IO option
findOption @BaseUrl
            (RequestLoggerMiddleware Middleware
requestLoggerMiddleware) <- Typeable RequestLoggerMiddleware =>
StateT TMap IO RequestLoggerMiddleware
forall option. Typeable option => StateT TMap IO option
findOption @RequestLoggerMiddleware
            (SessionCookie SetCookie
sessionCookie) <- Typeable SessionCookie => StateT TMap IO SessionCookie
forall option. Typeable option => StateT TMap IO option
findOption @SessionCookie
            MailServer
mailServer <- Typeable MailServer => StateT TMap IO MailServer
forall option. Typeable option => StateT TMap IO option
findOption @MailServer
            (DBPoolIdleTime NominalDiffTime
dbPoolIdleTime) <- Typeable DBPoolIdleTime => StateT TMap IO DBPoolIdleTime
forall option. Typeable option => StateT TMap IO option
findOption @DBPoolIdleTime
            (DBPoolMaxConnections Int
dbPoolMaxConnections) <- Typeable DBPoolMaxConnections =>
StateT TMap IO DBPoolMaxConnections
forall option. Typeable option => StateT TMap IO option
findOption @DBPoolMaxConnections
            (DatabaseUrl ByteString
databaseUrl) <- Typeable DatabaseUrl => StateT TMap IO DatabaseUrl
forall option. Typeable option => StateT TMap IO option
findOption @DatabaseUrl
            CSSFramework
cssFramework <- Typeable CSSFramework => StateT TMap IO CSSFramework
forall option. Typeable option => StateT TMap IO option
findOption @CSSFramework
            Logger
logger <- Typeable Logger => StateT TMap IO Logger
forall option. Typeable option => StateT TMap IO option
findOption @Logger
            ExceptionTracker
exceptionTracker <- Typeable ExceptionTracker => StateT TMap IO ExceptionTracker
forall option. Typeable option => StateT TMap IO option
findOption @ExceptionTracker

            FrameworkConfig -> StateT TMap IO FrameworkConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrameworkConfig :: Text
-> Environment
-> Int
-> Text
-> Middleware
-> SetCookie
-> MailServer
-> ByteString
-> NominalDiffTime
-> Int
-> CSSFramework
-> Logger
-> ExceptionTracker
-> FrameworkConfig
FrameworkConfig { Int
ByteString
Text
NominalDiffTime
Logger
MailServer
Environment
CSSFramework
SetCookie
ExceptionTracker
Middleware
$sel:exceptionTracker:FrameworkConfig :: ExceptionTracker
$sel:logger:FrameworkConfig :: Logger
$sel:cssFramework:FrameworkConfig :: CSSFramework
$sel:dbPoolMaxConnections:FrameworkConfig :: Int
$sel:dbPoolIdleTime:FrameworkConfig :: NominalDiffTime
$sel:databaseUrl:FrameworkConfig :: ByteString
$sel:mailServer:FrameworkConfig :: MailServer
$sel:sessionCookie:FrameworkConfig :: SetCookie
$sel:requestLoggerMiddleware:FrameworkConfig :: Middleware
$sel:baseUrl:FrameworkConfig :: Text
$sel:appPort:FrameworkConfig :: Int
$sel:environment:FrameworkConfig :: Environment
$sel:appHostname:FrameworkConfig :: Text
exceptionTracker :: ExceptionTracker
logger :: Logger
cssFramework :: CSSFramework
databaseUrl :: ByteString
dbPoolMaxConnections :: Int
dbPoolIdleTime :: NominalDiffTime
mailServer :: MailServer
sessionCookie :: SetCookie
requestLoggerMiddleware :: Middleware
baseUrl :: Text
appPort :: Int
environment :: Environment
appHostname :: Text
.. }

    (FrameworkConfig
frameworkConfig, TMap
_) <- StateT TMap IO FrameworkConfig
-> TMap -> IO (FrameworkConfig, TMap)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (StateT TMap IO ()
appConfig StateT TMap IO () -> StateT TMap IO () -> StateT TMap IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT TMap IO ()
ihpDefaultConfig StateT TMap IO ()
-> StateT TMap IO FrameworkConfig -> StateT TMap IO FrameworkConfig
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT TMap IO FrameworkConfig
resolve) TMap
TMap.empty

    FrameworkConfig -> IO FrameworkConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure FrameworkConfig
frameworkConfig
{-# INLINABLE buildFrameworkConfig #-}

data FrameworkConfig = FrameworkConfig
    { FrameworkConfig -> Text
appHostname :: !Text
    , FrameworkConfig -> Environment
environment :: !Environment
    , FrameworkConfig -> Int
appPort :: !Int
    , FrameworkConfig -> Text
baseUrl :: !Text

    -- | Provides IHP with a middleware to log requests and responses.
    --
    -- By default this uses the RequestLogger middleware from wai-extra. Take a look at the wai-extra
    -- documentation when you want to customize the request logging.
    --
    -- See https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html
    --
    --
    -- Set @requestLoggerMiddleware = \application -> application@ to disable request logging.
    , FrameworkConfig -> Middleware
requestLoggerMiddleware :: !Middleware

    -- | Provides the default settings for the session cookie.
    --
    -- - Max Age: 30 days
    -- - Same Site Policy: Lax
    -- - HttpOnly (no access through JS)
    -- - secure, when baseUrl is a https url
    --
    -- Override this to set e.g. a custom max age or change the default same site policy.
    --
    -- __Example: Set max age to 90 days__
    -- > sessionCookie = defaultIHPSessionCookie { Cookie.setCookieMaxAge = Just (fromIntegral (60 * 60 * 24 * 90)) }
    , FrameworkConfig -> SetCookie
sessionCookie :: !Cookie.SetCookie

    , FrameworkConfig -> MailServer
mailServer :: !MailServer

    , FrameworkConfig -> ByteString
databaseUrl :: !ByteString
    -- | How long db connection are kept alive inside the connecton pool when they're idle
    , FrameworkConfig -> NominalDiffTime
dbPoolIdleTime :: !NominalDiffTime

    -- | Max number of db connections the connection pool can open to the database
    , FrameworkConfig -> Int
dbPoolMaxConnections :: !Int

    -- | Bootstrap 4 by default
    --
    -- Override this if you use a CSS framework that is not bootstrap
    , FrameworkConfig -> CSSFramework
cssFramework :: !CSSFramework
    , FrameworkConfig -> Logger
logger :: !Logger
    , FrameworkConfig -> ExceptionTracker
exceptionTracker :: !ExceptionTracker
}

class ConfigProvider a where
    getFrameworkConfig :: a -> FrameworkConfig

instance ConfigProvider FrameworkConfig where
    getFrameworkConfig :: FrameworkConfig -> FrameworkConfig
getFrameworkConfig = FrameworkConfig -> FrameworkConfig
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

instance LoggingProvider FrameworkConfig where
    getLogger :: FrameworkConfig -> Logger
getLogger = Proxy "logger" -> FrameworkConfig -> Logger
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "logger" (Proxy "logger")
Proxy "logger"
#logger


-- | Proxies FrameworkConfig fields contained in some context that can provider a FrameworkConfig
fromConfig :: (?context :: context, ConfigProvider context) => (FrameworkConfig -> a) -> a
fromConfig :: (FrameworkConfig -> a) -> a
fromConfig FrameworkConfig -> a
selector = (FrameworkConfig -> a
selector (FrameworkConfig -> a)
-> (context -> FrameworkConfig) -> context -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. context -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig) context
?context::context
?context
{-# INLINE fromConfig #-}

-- | Get the current frameworkConfig
getConfig :: (?context :: context, ConfigProvider context) => FrameworkConfig
getConfig :: FrameworkConfig
getConfig = (FrameworkConfig -> FrameworkConfig) -> FrameworkConfig
forall context a.
(?context::context, ConfigProvider context) =>
(FrameworkConfig -> a) -> a
fromConfig FrameworkConfig -> FrameworkConfig
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINE getConfig #-}

-- | Returns the default IHP session cookie configuration. Useful when you want to override the default settings in 'sessionCookie'
defaultIHPSessionCookie :: Text -> Cookie.SetCookie
defaultIHPSessionCookie :: Text -> SetCookie
defaultIHPSessionCookie Text
baseUrl = SetCookie
forall a. Default a => a
def
    { setCookiePath :: Maybe ByteString
Cookie.setCookiePath = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/"
    , setCookieMaxAge :: Maybe DiffTime
Cookie.setCookieMaxAge = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (Integer -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
30))
    , setCookieSameSite :: Maybe SameSiteOption
Cookie.setCookieSameSite = SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
Cookie.sameSiteLax
    , setCookieHttpOnly :: Bool
Cookie.setCookieHttpOnly = Bool
True
    , setCookieSecure :: Bool
Cookie.setCookieSecure = Text
"https://" Text -> Text -> Bool
`Text.isPrefixOf` Text
baseUrl
    }

data RootApplication = RootApplication deriving (RootApplication -> RootApplication -> Bool
(RootApplication -> RootApplication -> Bool)
-> (RootApplication -> RootApplication -> Bool)
-> Eq RootApplication
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RootApplication -> RootApplication -> Bool
$c/= :: RootApplication -> RootApplication -> Bool
== :: RootApplication -> RootApplication -> Bool
$c== :: RootApplication -> RootApplication -> Bool
Eq, Int -> RootApplication -> ShowS
[RootApplication] -> ShowS
RootApplication -> String
(Int -> RootApplication -> ShowS)
-> (RootApplication -> String)
-> ([RootApplication] -> ShowS)
-> Show RootApplication
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RootApplication] -> ShowS
$cshowList :: [RootApplication] -> ShowS
show :: RootApplication -> String
$cshow :: RootApplication -> String
showsPrec :: Int -> RootApplication -> ShowS
$cshowsPrec :: Int -> RootApplication -> ShowS
Show)

defaultPort :: Int
defaultPort :: Int
defaultPort = Int
8000

defaultAppPort :: IO Int
defaultAppPort :: IO Int
defaultAppPort = do
    Maybe String
portStr <- String -> IO (Maybe String)
Environment.lookupEnv String
"PORT"
    case Maybe String
portStr of
        Just String
portStr -> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Text -> Int
forall a. Text -> a
error Text
"PORT: Invalid value") (String -> Maybe Int
forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay String
portStr)
        Maybe String
Nothing -> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
defaultPort

defaultDatabaseUrl :: IO ByteString
defaultDatabaseUrl :: IO ByteString
defaultDatabaseUrl = do
    String
currentDirectory <- IO String
getCurrentDirectory
    let defaultDatabaseUrl :: ByteString
defaultDatabaseUrl = ByteString
"postgresql:///app?host=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
currentDirectory ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/build/db"
    (String -> IO (Maybe String)
Environment.lookupEnv String
"DATABASE_URL") IO (Maybe String)
-> (Maybe String -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> (Maybe String -> ByteString) -> Maybe String -> IO ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> (String -> ByteString) -> Maybe String -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
defaultDatabaseUrl String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs )

defaultLoggerForEnv :: Environment -> IO Logger
defaultLoggerForEnv :: Environment -> IO Logger
defaultLoggerForEnv = \case
    Environment
Development -> IO Logger
defaultLogger
    Environment
Production -> LoggerSettings -> IO Logger
newLogger LoggerSettings
forall a. Default a => a
def { $sel:level:LoggerSettings :: LogLevel
level = LogLevel
Info }


-- Returns 'True' when the application is running in a given environment
isEnvironment :: (?context :: context, ConfigProvider context) => Environment -> Bool
isEnvironment :: Environment -> Bool
isEnvironment Environment
environment = (context -> FrameworkConfig
forall a. ConfigProvider a => a -> FrameworkConfig
getFrameworkConfig context
?context::context
?context FrameworkConfig -> (FrameworkConfig -> Environment) -> Environment
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "environment" -> FrameworkConfig -> Environment
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "environment" (Proxy "environment")
Proxy "environment"
#environment) Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
environment
{-# INLINABLE isEnvironment #-}

-- | Returns 'True'  when the application is running in Development mode
--
-- Development mode means that the Development option is configured in Config/Config.hs
isDevelopment :: (?context :: context, ConfigProvider context) => Bool
isDevelopment :: Bool
isDevelopment = Environment -> Bool
forall context.
(?context::context, ConfigProvider context) =>
Environment -> Bool
isEnvironment Environment
Development
{-# INLINABLE isDevelopment #-}

-- | Returns 'True' when the application is running in Production mode
--
-- Production mode means that the Production option is configured in Config/Config.hs
isProduction :: (?context :: context, ConfigProvider context) => Bool
isProduction :: Bool
isProduction = Environment -> Bool
forall context.
(?context::context, ConfigProvider context) =>
Environment -> Bool
isEnvironment Environment
Production
{-# INLINABLE isProduction #-}