{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}

module Application
  ( getApplicationDev
  , appMain
  , develMain
  , makeFoundation
  , makeLogWare
   -- * for DevelMain
  , getApplicationRepl
  , shutdownApp
   -- * for GHCI
  , handler
  , db
  ) where

import           Control.Monad.Logger (liftLoc, runLoggingT)
import           Database.Persist.Sqlite (ConnectionPool, mkSqliteConnectionInfo, createSqlitePoolFromInfo, fkEnabled, runSqlPool, sqlDatabase, sqlPoolSize)
import           Import
import           Language.Haskell.TH.Syntax (qLocation)
import           Lens.Micro
import           Network.HTTP.Client.TLS
import           Network.Wai (Middleware)
import           Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, runSettings, setHost, setOnException, setPort, getPort)
import           Network.Wai.Middleware.AcceptOverride
import           Network.Wai.Middleware.Autohead
import           Network.Wai.Middleware.Gzip
import           Network.Wai.Middleware.MethodOverride
import           Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat)
import           System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
#ifndef mingw32_HOST_OS
import qualified Control.Concurrent as CC (killThread, myThreadId)
import qualified System.Posix.Signals as PS (installHandler, Handler(CatchOnce), sigTERM)
#endif

-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import           Handler.Common
import           Handler.Home
import           Handler.User
import           Handler.AccountSettings
import           Handler.Add
import           Handler.Edit
import           Handler.Notes
import           Handler.Docs

mkYesodDispatch "App" resourcesApp

makeFoundation :: AppSettings -> IO App
makeFoundation :: AppSettings -> IO App
makeFoundation AppSettings
appSettings = do
  Manager
appHttpManager <- IO Manager
getGlobalManager
  Logger
appLogger <- BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
defaultBufSize 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)
  let mkFoundation :: ConnectionPool -> App
mkFoundation ConnectionPool
appConnPool = App {Static
Manager
ConnectionPool
Logger
AppSettings
appLogger :: Logger
appHttpManager :: Manager
appConnPool :: ConnectionPool
appSettings :: AppSettings
appConnPool :: ConnectionPool
appStatic :: Static
appLogger :: Logger
appHttpManager :: Manager
appSettings :: AppSettings
appStatic :: Static
..}
      tempFoundation :: App
tempFoundation = ConnectionPool -> App
mkFoundation (forall a. HasCallStack => String -> a
error String
"connPool forced in tempFoundation")
      logFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc = forall site.
Yesod site =>
site -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource App
tempFoundation Logger
appLogger
  ConnectionPool
pool <- (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Bool -> IO ConnectionPool
mkPool Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc Bool
True
  ConnectionPool
poolMigrations <- (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Bool -> IO ConnectionPool
mkPool Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc Bool
False
  forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool DB ()
runMigrations ConnectionPool
poolMigrations) Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc
  forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectionPool -> App
mkFoundation ConnectionPool
pool)
  where
    mkPool :: _ -> Bool -> IO ConnectionPool
    mkPool :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Bool -> IO ConnectionPool
mkPool Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc Bool
isFkEnabled =
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc forall a b. (a -> b) -> a -> b
$ do
        let dbPath :: LogSource
dbPath = SqliteConf -> LogSource
sqlDatabase (AppSettings -> SqliteConf
appDatabaseConf AppSettings
appSettings)
            poolSize :: BufSize
poolSize = SqliteConf -> BufSize
sqlPoolSize (AppSettings -> SqliteConf
appDatabaseConf AppSettings
appSettings)
            connInfo :: SqliteConnectionInfo
connInfo = LogSource -> SqliteConnectionInfo
mkSqliteConnectionInfo LogSource
dbPath forall a b. a -> (a -> b) -> b
&
                       forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SqliteConnectionInfo Bool
fkEnabled Bool
isFkEnabled
        forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
SqliteConnectionInfo -> BufSize -> m ConnectionPool
createSqlitePoolFromInfo SqliteConnectionInfo
connInfo BufSize
poolSize


makeApplication :: App -> IO Application
makeApplication :: App -> IO Application
makeApplication App
foundation = do
  Middleware
logWare <- App -> IO Middleware
makeLogWare App
foundation
  Application
appPlain <- forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain App
foundation
  forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware
logWare (Middleware
makeMiddleware Application
appPlain))

makeMiddleware :: Middleware
makeMiddleware :: Middleware
makeMiddleware =
  Middleware
acceptOverride forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
  Middleware
autohead forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
  GzipSettings -> Middleware
gzip forall a. Default a => a
def {gzipFiles :: GzipFiles
gzipFiles = GzipFiles -> GzipFiles
GzipPreCompressed GzipFiles
GzipIgnore} forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
  Middleware
methodOverride

makeLogWare :: App -> IO Middleware
makeLogWare :: App -> IO Middleware
makeLogWare App
foundation =
  RequestLoggerSettings -> IO Middleware
mkRequestLogger
    forall a. Default a => a
def
    { outputFormat :: OutputFormat
outputFormat =
      if AppSettings -> Bool
appDetailedRequestLogging (App -> AppSettings
appSettings App
foundation)
        then Bool -> OutputFormat
Detailed Bool
True
        else IPAddrSource -> OutputFormat
Apache
               (if AppSettings -> Bool
appIpFromHeader (App -> AppSettings
appSettings App
foundation)
                  then IPAddrSource
FromFallback
                  else IPAddrSource
FromSocket)
    , destination :: Destination
destination = LoggerSet -> Destination
Logger (Logger -> LoggerSet
loggerSet (App -> Logger
appLogger App
foundation))
    }

-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings :: App -> Settings
warpSettings App
foundation =
  BufSize -> Settings -> Settings
setPort (AppSettings -> BufSize
appPort (App -> AppSettings
appSettings App
foundation)) forall a b. (a -> b) -> a -> b
$
  HostPreference -> Settings -> Settings
setHost (AppSettings -> HostPreference
appHost (App -> AppSettings
appSettings App
foundation)) forall a b. (a -> b) -> a -> b
$
  (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
setOnException
    (\Maybe Request
_req SomeException
e ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
defaultShouldDisplayException SomeException
e) forall a b. (a -> b) -> a -> b
$
        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
          (forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall a b. (a -> b) -> a -> b
$ String
"Exception from Warp: " forall m. Monoid m => m -> m -> m
++ forall a. Show a => a -> String
show SomeException
e))
    Settings
defaultSettings

-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
  AppSettings
settings <- IO AppSettings
getAppSettings
  App
foundation <- AppSettings -> IO App
makeFoundation AppSettings
settings
  Settings
wsettings <- Settings -> IO Settings
getDevSettings (App -> Settings
warpSettings App
foundation)
  Application
app <- App -> IO Application
makeApplication App
foundation
  forall (m :: * -> *) a. Monad m => a -> m a
return (Settings
wsettings, Application
app)

getAppSettings :: IO AppSettings
getAppSettings :: IO AppSettings
getAppSettings = forall settings.
FromJSON settings =>
[String] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings [String
configSettingsYml] [] EnvUsage
useEnv

-- | main function for use by yesod devel
develMain :: IO ()
develMain :: IO ()
develMain = IO (Settings, Application) -> IO ()
develMainHelper IO (Settings, Application)
getApplicationDev

-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain :: IO ()
appMain = do
  AppSettings
settings <- forall settings.
FromJSON settings =>
[Value] -> EnvUsage -> IO settings
loadYamlSettingsArgs [Value
configSettingsYmlValue] EnvUsage
useEnv
  App
foundation <- AppSettings -> IO App
makeFoundation AppSettings
settings
  Application
app <- App -> IO Application
makeApplication App
foundation
#ifndef mingw32_HOST_OS
  ThreadId
mainThreadId <- IO ThreadId
CC.myThreadId
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
PS.installHandler Signal
PS.sigTERM (IO () -> Handler
PS.CatchOnce (ThreadId -> IO ()
CC.killThread ThreadId
mainThreadId)) forall a. Maybe a
Nothing
#endif
  Settings -> Application -> IO ()
runSettings (App -> Settings
warpSettings App
foundation) Application
app
  
getApplicationRepl :: IO (Int, App, Application)
getApplicationRepl :: IO (BufSize, App, Application)
getApplicationRepl = do
  AppSettings
settings <- IO AppSettings
getAppSettings
  App
foundation <- AppSettings -> IO App
makeFoundation AppSettings
settings
  Settings
wsettings <- Settings -> IO Settings
getDevSettings (App -> Settings
warpSettings App
foundation)
  Application
app1 <- App -> IO Application
makeApplication App
foundation
  forall (m :: * -> *) a. Monad m => a -> m a
return (Settings -> BufSize
getPort Settings
wsettings, App
foundation, Application
app1)

shutdownApp :: App -> IO ()
shutdownApp :: App -> IO ()
shutdownApp App
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Run a handler
handler :: Handler a -> IO a
handler :: forall a. Handler a -> IO a
handler Handler a
h = IO AppSettings
getAppSettings forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AppSettings -> IO App
makeFoundation forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. App -> Handler a -> IO a
unsafeHandler Handler a
h

-- | Run DB queries
db :: ReaderT SqlBackend (HandlerFor App) a -> IO a
db :: forall a. ReaderT SqlBackend (HandlerFor App) a -> IO a
db = forall a. Handler a -> IO a
handler forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB