{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module BtcLsp.Yesod.Application
  ( appMain,
  )
where

-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!

import qualified BtcLsp.Class.Env as Class
import BtcLsp.Yesod.Handler.About
import BtcLsp.Yesod.Handler.Common
import BtcLsp.Yesod.Handler.Home
import BtcLsp.Yesod.Handler.Language
import BtcLsp.Yesod.Handler.OpenChan
import BtcLsp.Yesod.Handler.SwapIntoLnCreate
import BtcLsp.Yesod.Handler.SwapIntoLnSelect
import BtcLsp.Yesod.Handler.SwapUpdates
import BtcLsp.Yesod.Import
import Control.Monad.Logger (liftLoc)
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware, pathInfo)
import Network.Wai.Handler.Warp
  ( Settings,
    defaultSettings,
    defaultShouldDisplayException,
    runSettings,
    setHost,
    setOnException,
    setPort,
  )
import Network.Wai.Middleware.RequestLogger
  ( Destination (Logger),
    DetailedSettings (..),
    OutputFormat (..),
    destination,
    mkRequestLogger,
    outputFormat,
  )
import System.Log.FastLogger
  ( defaultBufSize,
    newStdoutLoggerSet,
    toLogStr,
  )

-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
mkYesodDispatch "App" resourcesApp

-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation ::
  ( Class.Env m
  ) =>
  Pool SqlBackend ->
  UnliftIO m ->
  AppSettings ->
  IO App
makeFoundation :: forall (m :: * -> *).
Env m =>
Pool SqlBackend -> UnliftIO m -> AppSettings -> IO App
makeFoundation Pool SqlBackend
sqlPool UnliftIO m
appMRunner AppSettings
appSettings = do
  -- Some basic initializations: HTTP connection manager, logger, and static
  -- subsite.
  Manager
appHttpManager <- IO Manager
getGlobalManager
  Logger
appLogger <- BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
defaultBufSize IO LoggerSet -> (LoggerSet -> IO Logger) -> IO Logger
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggerSet -> IO Logger
makeYesodLogger
  Static
appStatic <-
    (if AppSettings -> Bool
appMutableStatic AppSettings
appSettings then String -> IO Static
staticDevel else String -> IO Static
static)
      (AppSettings -> String
appStaticDir AppSettings
appSettings)

  -- We need a log function to create a connection pool. We need a connection
  -- pool to create our foundation. And we need our foundation to get a
  -- logging function. To get out of this loop, we initially create a
  -- temporary foundation without a real connection pool, get a log function
  -- from there, and then create the real foundation.
  let mkFoundation :: Pool SqlBackend -> App
mkFoundation Pool SqlBackend
appConnPool = App :: forall (m :: * -> *).
Env m =>
AppSettings
-> Static
-> Pool SqlBackend
-> Manager
-> Logger
-> UnliftIO m
-> App
App {UnliftIO m
Static
Manager
Pool SqlBackend
Logger
AppSettings
appMRunner :: UnliftIO m
appLogger :: Logger
appHttpManager :: Manager
appConnPool :: Pool SqlBackend
appSettings :: AppSettings
appConnPool :: Pool SqlBackend
appStatic :: Static
appLogger :: Logger
appHttpManager :: Manager
appSettings :: AppSettings
appMRunner :: UnliftIO m
appStatic :: Static
..}
  -- The App {..} syntax is an example of record wild cards. For more
  -- information, see:
  -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html

  -- Return the foundation
  App -> IO App
forall (m :: * -> *) a. Monad m => a -> m a
return (App -> IO App) -> App -> IO App
forall a b. (a -> b) -> a -> b
$ Pool SqlBackend -> App
mkFoundation Pool SqlBackend
sqlPool

-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: YesodLog -> App -> IO Application
makeApplication :: YesodLog -> App -> IO Application
makeApplication YesodLog
yesodLog App
foundation = do
  Middleware
logWare <- YesodLog -> App -> IO Middleware
makeLogWare YesodLog
yesodLog App
foundation
  -- Create the WAI application and apply middlewares
  Application
appPlain <- App -> IO Application
forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain App
foundation
  Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ Middleware
logWare Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Middleware
defaultMiddlewaresNoLogging Application
appPlain

makeLogWare :: YesodLog -> App -> IO Middleware
makeLogWare :: YesodLog -> App -> IO Middleware
makeLogWare YesodLog
yesodLog App
foundation =
  RequestLoggerSettings -> IO Middleware
mkRequestLogger
    RequestLoggerSettings
forall a. Default a => a
def
      { outputFormat :: OutputFormat
outputFormat =
          DetailedSettings -> OutputFormat
DetailedWithSettings (DetailedSettings -> OutputFormat)
-> DetailedSettings -> OutputFormat
forall a b. (a -> b) -> a -> b
$
            DetailedSettings
forall a. Default a => a
def
              { useColors :: Bool
useColors = Bool
True,
                mFilterRequests :: Maybe (Request -> Response -> Bool)
mFilterRequests = (Request -> Response -> Bool)
-> Maybe (Request -> Response -> Bool)
forall a. a -> Maybe a
Just ((Request -> Response -> Bool)
 -> Maybe (Request -> Response -> Bool))
-> (Request -> Response -> Bool)
-> Maybe (Request -> Response -> Bool)
forall a b. (a -> b) -> a -> b
$ YesodLog -> Request -> Response -> Bool
forall {b}. YesodLog -> Request -> b -> Bool
reqFilter YesodLog
yesodLog
              },
        destination :: Destination
destination =
          LoggerSet -> Destination
Logger
            (LoggerSet -> Destination)
-> (Logger -> LoggerSet) -> Logger -> Destination
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Logger -> LoggerSet
loggerSet
            (Logger -> Destination) -> Logger -> Destination
forall a b. (a -> b) -> a -> b
$ App -> Logger
appLogger App
foundation
      }
  where
    reqFilter :: YesodLog -> Request -> b -> Bool
reqFilter YesodLog
YesodLogAll Request
_ =
      Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True
    reqFilter YesodLog
YesodLogNothing Request
_ =
      Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False
    reqFilter YesodLog
YesodLogNoMain Request
req =
      Bool -> b -> Bool
forall a b. a -> b -> a
const (Bool -> b -> Bool) -> Bool -> b -> Bool
forall a b. (a -> b) -> a -> b
$
        case Request -> [LogSource]
pathInfo Request
req of
          [] -> Bool
False
          LogSource
x : [LogSource]
_ ->
            LogSource
Element [LogSource]
x
              Element [LogSource] -> [LogSource] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`notElem` [ LogSource
"static",
                          LogSource
"favicon.ico",
                          LogSource
"robots.txt"
                        ]

-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings :: App -> Settings
warpSettings App
foundation =
  BufSize -> Settings -> Settings
setPort (AppSettings -> BufSize
appPort (AppSettings -> BufSize) -> AppSettings -> BufSize
forall a b. (a -> b) -> a -> b
$ App -> AppSettings
appSettings App
foundation) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
    HostPreference -> Settings -> Settings
setHost (AppSettings -> HostPreference
appHost (AppSettings -> HostPreference) -> AppSettings -> HostPreference
forall a b. (a -> b) -> a -> b
$ App -> AppSettings
appSettings App
foundation) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
      (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
setOnException
        ( \Maybe Request
_req SomeException
e ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
defaultShouldDisplayException SomeException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              App -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall site.
Yesod site =>
site -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource
                App
foundation
                (App -> Logger
appLogger App
foundation)
                $(qLocation >>= liftLoc)
                LogSource
"yesod"
                LogLevel
LevelError
                (String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ String
"Exception from Warp: " String -> String -> String
forall m. Monoid m => m -> m -> m
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
        )
        Settings
defaultSettings

-- | The @main@ function for an executable running this site.
appMain ::
  ( Class.Env m
  ) =>
  YesodLog ->
  Pool SqlBackend ->
  UnliftIO m ->
  IO ()
appMain :: forall (m :: * -> *).
Env m =>
YesodLog -> Pool SqlBackend -> UnliftIO m -> IO ()
appMain YesodLog
yesodLog Pool SqlBackend
sqlPool UnliftIO m
appMRunner = do
  -- Get the settings from all relevant sources
  AppSettings
settings <-
    [Value] -> EnvUsage -> IO AppSettings
forall settings.
FromJSON settings =>
[Value] -> EnvUsage -> IO settings
loadYamlSettingsArgs
      -- fall back to compile-time values, set to [] to require values at runtime
      [Value
configSettingsYmlValue]
      -- allow environment variables to override
      EnvUsage
useEnv

  -- Generate the foundation from the settings
  App
foundation <- Pool SqlBackend -> UnliftIO m -> AppSettings -> IO App
forall (m :: * -> *).
Env m =>
Pool SqlBackend -> UnliftIO m -> AppSettings -> IO App
makeFoundation Pool SqlBackend
sqlPool UnliftIO m
appMRunner AppSettings
settings

  -- Generate a WAI Application from the foundation
  Application
app <- YesodLog -> App -> IO Application
makeApplication YesodLog
yesodLog App
foundation

  -- Run the application with Warp
  Settings -> Application -> IO ()
runSettings (App -> Settings
warpSettings App
foundation) Application
app