{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
module Application
( getApplicationDev
, appMain
, develMain
, makeFoundation
, makeLogWare
, getApplicationRepl
, shutdownApp
, 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 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))
}
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
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
develMain :: IO ()
develMain :: IO ()
develMain = IO (Settings, Application) -> IO ()
develMainHelper IO (Settings, Application)
getApplicationDev
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 ()
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
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