{-# 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 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))
}
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
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
develMain :: IO ()
develMain :: IO ()
develMain = IO (Settings, Application) -> IO ()
develMainHelper IO (Settings, Application)
getApplicationDev
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 ()
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
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