gonito/Application.hs

260 lines
9.3 KiB
Haskell
Raw Normal View History

2015-08-20 22:33:38 +02:00
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev
, appMain
2018-06-01 07:48:04 +02:00
, appSelfContainedMain
2015-08-20 22:33:38 +02:00
, develMain
, makeFoundation
2018-09-20 13:02:07 +02:00
, makeLogWare
2015-08-20 22:33:38 +02:00
-- * for DevelMain
, getApplicationRepl
, shutdownApp
-- * for GHCI
, handler
, db
) where
import Control.Monad.Logger (liftLoc, runLoggingT)
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
pgPoolSize, runSqlPool)
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException,
runSettings, setHost,
setOnException, setPort, getPort)
2018-09-20 13:02:07 +02:00
import Network.Wai (Middleware)
2015-08-20 22:33:38 +02:00
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..), destination,
mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
toLogStr)
2018-06-01 16:30:35 +02:00
import Crypto.PasswordStore
import Yesod.Auth.HashDB (defaultStrength)
2015-08-29 18:24:01 +02:00
import qualified Data.IntMap as IntMap
2015-08-20 22:33:38 +02:00
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Common
2016-05-03 08:46:10 +02:00
import Handler.Discussion
2016-02-11 21:54:22 +01:00
import Handler.Graph
2015-08-20 22:33:38 +02:00
import Handler.Home
2015-08-29 14:58:47 +02:00
import Handler.CreateChallenge
2015-09-04 23:23:32 +02:00
import Handler.ListChallenges
2016-02-15 11:43:47 +01:00
import Handler.MakePublic
2016-02-12 13:00:33 +01:00
import Handler.Query
2015-09-04 23:23:32 +02:00
import Handler.ShowChallenge
2015-08-29 18:24:01 +02:00
import Handler.Shared
2015-09-30 20:15:33 +02:00
import Handler.YourAccount
2017-02-18 10:26:02 +01:00
import Handler.AccountReset
2016-05-16 23:44:28 +02:00
import Handler.Presentation
2017-02-19 14:05:56 +01:00
import Handler.Tags
2017-02-19 22:26:01 +01:00
import Handler.EditSubmission
2020-07-11 14:14:35 +02:00
import Handler.Annotations
2017-02-26 21:40:38 +01:00
import Handler.Achievements
2017-05-15 13:55:56 +02:00
import Handler.Score
2018-01-02 18:55:35 +01:00
import Handler.ExtraPoints
import Handler.Dashboard
import Handler.Evaluate
2015-08-20 22:33:38 +02:00
-- 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 :: AppSettings -> IO App
makeFoundation appSettings = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appHttpManager <- newManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic appSettings then staticDevel else static)
(appStaticDir appSettings)
2015-08-29 18:24:01 +02:00
jobs <- newTVarIO IntMap.empty
nextJob <- newTVarIO 1
2015-08-20 22:33:38 +02:00
-- 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 appConnPool = App {..}
-- 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
tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
logFunc = messageLoggerSource tempFoundation appLogger
-- Create the database connection pool
pool <- flip runLoggingT logFunc $ createPostgresqlPool
(pgConnStr $ appDatabaseConf appSettings)
(pgPoolSize $ appDatabaseConf appSettings)
-- Perform database migration using our application's logging settings.
2018-06-01 16:30:35 +02:00
runLoggingT (runSqlPool ((runMigration migrateAll) >> (initAdmin (appAdminUser appSettings) (appAdminPassword appSettings))) pool) logFunc
2015-08-20 22:33:38 +02:00
-- Return the foundation
return $ mkFoundation pool
2018-06-01 16:30:35 +02:00
initAdmin Nothing Nothing = return ()
initAdmin (Just "") _ = return ()
initAdmin (Just adminUser) (Just adminPass) = do
mUserEnt <- getBy $ UniqueUser adminUser
case mUserEnt of
Just _ -> return ()
Nothing -> do
passwordEncoded <- liftIO $ makePassword (encodeUtf8 adminPass) defaultStrength
_ <- insert User
{ userIdent = adminUser
, userPassword = Just $ decodeUtf8 passwordEncoded
, userName = Nothing
, userIsAdmin = True
, userLocalId = Nothing
, userIsAnonymous = False
, userAvatar = Nothing
, userVerificationKey = Nothing
, userKeyExpirationDate = Nothing
, userTriggerToken = Nothing
, userAltRepoScheme = Nothing
2018-06-01 16:30:35 +02:00
}
return ()
2015-08-20 22:33:38 +02:00
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
logWare <- mkRequestLogger def
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
}
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
2018-09-20 13:02:07 +02:00
makeLogWare :: App -> IO Middleware
makeLogWare foundation =
mkRequestLogger def
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
}
2015-08-20 22:33:38 +02:00
-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings foundation =
setPort (appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation)
$ setOnException (\_req e ->
when (defaultShouldDisplayException e) $ messageLoggerSource
foundation
(appLogger foundation)
$(qLocation >>= liftLoc)
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app <- makeApplication foundation
return (wsettings, app)
getAppSettings :: IO AppSettings
getAppSettings = loadAppSettings [configSettingsYml] [] useEnv
-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev
-- | The @main@ function for an executable running this site.
appMain = do
-- Get the settings from all relevant sources
settings <- loadAppSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue]
-- allow environment variables to override
useEnv
-- Generate the foundation from the settings
foundation <- makeFoundation settings
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
-- Run the application with Warp
-- runSettings (warpSettings foundation) app
2018-06-01 07:48:04 +02:00
return app
-- | The @main@ function for an executable running this site.
appSelfContainedMain :: IO ()
appSelfContainedMain = do
-- Get the settings from all relevant sources
settings <- loadAppSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue]
-- allow environment variables to override
useEnv
-- Generate the foundation from the settings
foundation <- makeFoundation settings
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
-- Run the application with Warp
runSettings (warpSettings foundation) app
2015-08-20 22:33:38 +02:00
--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
getApplicationRepl :: IO (Int, App, Application)
getApplicationRepl = do
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation
return (getPort wsettings, foundation, app1)
shutdownApp :: App -> IO ()
shutdownApp _ = return ()
---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------
-- | Run a handler
handler :: Handler a -> IO a
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
-- | Run DB queries
db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a
db = handler . runDB