{-# 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 IO LoggerSet -> (LoggerSet -> IO Logger) -> IO Logger
forall a b. IO a -> (a -> IO b) -> IO b
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 {Manager
Static
ConnectionPool
Logger
AppSettings
appStatic :: Static
appSettings :: AppSettings
appHttpManager :: Manager
appLogger :: Logger
appStatic :: Static
appConnPool :: ConnectionPool
appSettings :: AppSettings
appConnPool :: ConnectionPool
appHttpManager :: Manager
appLogger :: Logger
..}
      tempFoundation :: App
tempFoundation = ConnectionPool -> App
mkFoundation (String -> ConnectionPool
forall a. HasCallStack => String -> a
error String
"connPool forced in tempFoundation")
      logFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc = App -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
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
  LoggingT IO ()
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (ReaderT SqlBackend (LoggingT IO) ()
-> ConnectionPool -> LoggingT IO ()
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool ReaderT SqlBackend (LoggingT IO) ()
DB ()
runMigrations ConnectionPool
poolMigrations) Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc
  App -> IO App
forall a. a -> IO a
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 =
      (LoggingT IO ConnectionPool
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
 -> IO ConnectionPool)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT IO ConnectionPool
-> IO ConnectionPool
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO ConnectionPool
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> IO ConnectionPool
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logFunc (LoggingT IO ConnectionPool -> IO ConnectionPool)
-> LoggingT IO ConnectionPool -> IO ConnectionPool
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 SqliteConnectionInfo
-> (SqliteConnectionInfo -> SqliteConnectionInfo)
-> SqliteConnectionInfo
forall a b. a -> (a -> b) -> b
&
                       ASetter SqliteConnectionInfo SqliteConnectionInfo Bool Bool
-> Bool -> SqliteConnectionInfo -> SqliteConnectionInfo
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter SqliteConnectionInfo SqliteConnectionInfo Bool Bool
Lens' SqliteConnectionInfo Bool
fkEnabled Bool
isFkEnabled
        SqliteConnectionInfo -> BufSize -> LoggingT IO ConnectionPool
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 <- App -> IO Application
forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain App
foundation
  Application -> IO Application
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware
logWare (Middleware
makeMiddleware Application
appPlain))

makeMiddleware :: Middleware
makeMiddleware :: Middleware
makeMiddleware =
  Middleware
acceptOverride Middleware -> Middleware -> Middleware
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
.
  Middleware
autohead Middleware -> Middleware -> Middleware
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
.
  GzipSettings -> Middleware
gzip GzipSettings
forall a. Default a => a
def {gzipFiles = GzipPreCompressed GzipIgnore} Middleware -> Middleware -> Middleware
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
.
  Middleware
methodOverride

makeLogWare :: App -> IO Middleware
makeLogWare :: App -> IO Middleware
makeLogWare App
foundation =
  RequestLoggerSettings -> IO Middleware
mkRequestLogger
    RequestLoggerSettings
forall a. Default a => a
def
    { outputFormat =
      if appDetailedRequestLogging (appSettings foundation)
        then Detailed True
        else Apache
               (if appIpFromHeader (appSettings foundation)
                  then FromFallback
                  else FromSocket)
    , destination = Logger (loggerSet (appLogger 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)) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
  HostPreference -> Settings -> Settings
setHost (AppSettings -> HostPreference
appHost (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

-- | 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
  (Settings, Application) -> IO (Settings, Application)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Settings
wsettings, Application
app)

getAppSettings :: IO AppSettings
getAppSettings :: IO AppSettings
getAppSettings = [String] -> [Value] -> EnvUsage -> IO AppSettings
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 <- [Value] -> EnvUsage -> IO AppSettings
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
  IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
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)) Maybe SignalSet
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
  (BufSize, App, Application) -> IO (BufSize, App, Application)
forall a. a -> IO a
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
_ = () -> IO ()
forall a. a -> IO a
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 IO AppSettings -> (AppSettings -> IO App) -> IO App
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AppSettings -> IO App
makeFoundation IO App -> (App -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (App -> Handler a -> IO a) -> Handler a -> App -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip App -> Handler a -> IO a
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 = Handler a -> IO a
forall a. Handler a -> IO a
handler (Handler a -> IO a)
-> (ReaderT SqlBackend (HandlerFor App) a -> Handler a)
-> ReaderT SqlBackend (HandlerFor App) a
-> IO a
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
. ReaderT SqlBackend (HandlerFor App) a -> Handler a
YesodDB App a -> Handler a
forall a. YesodDB App a -> HandlerFor App a
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB