eidolon/Application.hs

178 lines
6.8 KiB
Haskell
Raw Normal View History

2015-01-18 19:44:41 +00:00
-- eidolon -- A simple gallery in Haskell and Yesod
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
2015-01-21 09:00:18 +00:00
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-01-18 19:44:41 +00:00
2014-08-09 18:33:22 +00:00
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev
2014-08-09 18:33:22 +00:00
, makeFoundation
, develMain
, appMain
2014-08-09 18:33:22 +00:00
) where
import Import
import Yesod.Default.Config2
2014-08-09 18:33:22 +00:00
import Yesod.Default.Handlers
import Database.Persist.Sql (runMigration)
import Network.HTTP.Client.Conduit (newManager)
import Control.Monad
2015-09-14 16:54:46 +00:00
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, toLogStr)
2014-08-09 18:33:22 +00:00
import Data.Default (def)
import Yesod.Core.Types (loggerSet)
import Control.Monad.Logger (liftLoc, runLoggingT)
import Database.Persist.Postgresql (createPostgresqlPool, runSqlPool,
pgConnStr, pgPoolSize)
import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException,
runSettings, setHost,
setOnException, setPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..), destination,
mkRequestLogger, outputFormat)
2014-08-09 18:33:22 +00:00
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Home
2014-08-12 12:37:31 +00:00
import Handler.Signup
import Handler.Login
import Handler.Activate
import Handler.Profile
import Handler.Upload
2014-08-13 22:49:37 +00:00
import Handler.NewAlbum
2014-08-17 20:59:17 +00:00
import Handler.Album
2014-08-18 04:06:16 +00:00
import Handler.Medium
2014-08-28 16:08:56 +00:00
import Handler.AlbumSettings
2014-08-30 18:25:08 +00:00
import Handler.MediumSettings
2014-09-04 01:57:01 +00:00
import Handler.Reactivate
2014-09-05 18:40:12 +00:00
import Handler.ProfileSettings
import Handler.ProfileDelete
import Handler.Admin
import Handler.AdminProfileSettings
2014-09-07 04:56:34 +00:00
import Handler.AdminAlbumSettings
2014-09-09 02:25:47 +00:00
import Handler.AdminMediumSettings
2014-12-21 19:01:03 +00:00
import Handler.AdminComments
2014-09-14 03:03:13 +00:00
import Handler.Tag
2014-12-14 19:21:23 +00:00
import Handler.RootFeed
2016-09-04 17:56:36 +00:00
-- import Handler.Search
2014-08-09 18:33:22 +00: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 return a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
2014-08-09 18:33:22 +00:00
-- 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)
-- 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 {..}
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.
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
-- Return the foundation
return $ mkFoundation pool
2014-08-09 18:33:22 +00:00
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applyng some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
2014-08-09 18:33:22 +00:00
logWare <- mkRequestLogger def
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
2014-08-09 18:33:22 +00:00
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
2014-08-09 18:33:22 +00:00
}
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
2014-08-09 18:33:22 +00: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
2016-08-27 11:41:02 +00:00
settings <- loadYamlSettings [configSettingsYml] [] useEnv
foundation <- makeFoundation settings
app <- makeApplication foundation
wsettings <- getDevSettings $ warpSettings foundation
return (wsettings, app)
-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev
-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
-- Get the settings from all relevant sources
2016-08-27 11:41:02 +00:00
settings <- loadYamlSettingsArgs
-- 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