Skip to content

Commit af0529b

Browse files
pSubpSub
committed
Update codebase to latest Yesod version
1 parent a35dffc commit af0529b

File tree

13 files changed

+443
-313
lines changed

13 files changed

+443
-313
lines changed

‎Application.hs‎

Lines changed: 146 additions & 62 deletions
Original file line numberDiff line numberDiff line change
@@ -1,28 +1,33 @@
11
{-# OPTIONS_GHC -fno-warn-orphans #-}
22
module Application
3-
( makeApplication
4-
, getApplicationDev
3+
( getApplicationDev
4+
, appMain
5+
, develMain
56
, makeFoundation
7+
-- * for DevelMain
8+
, getApplicationRepl
9+
, shutdownApp
10+
-- * for GHCI
11+
, handler
12+
, db
613
) where
714

15+
import Control.Monad.Logger (liftLoc, runLoggingT)
16+
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
17+
pgPoolSize, runSqlPool)
818
import Import
9-
import Settings
10-
import Yesod.Auth
11-
import Yesod.Default.Config
12-
import Yesod.Default.Main
19+
import Language.Haskell.TH.Syntax (qLocation)
20+
import Network.Wai.Handler.Warp (Settings, defaultSettings,
21+
defaultShouldDisplayException,
22+
runSettings, setHost,
23+
setOnException, setPort, getPort)
24+
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
25+
IPAddrSource (..),
26+
OutputFormat (..), destination,
27+
mkRequestLogger, outputFormat)
28+
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
29+
toLogStr)
1330
import Yesod.Default.Handlers
14-
import Network.Wai.Middleware.RequestLogger
15-
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
16-
)
17-
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
18-
import qualified Database.Persist
19-
import Database.Persist.Sql (runMigration)
20-
import Network.HTTP.Conduit (newManager, conduitManagerSettings)
21-
import Control.Monad.Logger (runLoggingT)
22-
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
23-
import Network.Wai.Logger (clockDateCacher)
24-
import Data.Default (def)
25-
import Yesod.Core.Types (loggerSet, Logger (Logger))
2631

2732
-- Import all relevant handler modules here.
2833
import Handler.Admin
@@ -38,56 +43,135 @@ import Handler.Sitemap
3843
-- comments there for more details.
3944
mkYesodDispatch "App" resourcesApp
4045

41-
-- This function allocates resources (such as a database connection pool),
42-
-- performs initialization and creates a WAI application. This is also the
43-
-- place to put your migrate statements to have automatic database
46+
-- | This function allocates resources (such as a database connection pool),
47+
-- performs initialization and return a foundation datatype value. This is also
48+
-- the place to put your migrate statements to have automatic database
4449
-- migrations handled by Yesod.
45-
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
46-
makeApplication conf = do
47-
foundation <- makeFoundation conf
50+
makeFoundation :: AppSettings -> IO App
51+
makeFoundation appSettings = do
52+
-- Some basic initializations: HTTP connection manager, logger, and static
53+
-- subsite.
54+
appHttpManager <- newManager
55+
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
56+
appStatic <-
57+
(if appMutableStatic appSettings then staticDevel else static)
58+
(appStaticDir appSettings)
4859

49-
-- Initialize the logging middleware
60+
-- We need a log function to create a connection pool. We need a connection
61+
-- pool to create our foundation. And we need our foundation to get a
62+
-- logging function. To get out of this loop, we initially create a
63+
-- temporary foundation without a real connection pool, get a log function
64+
-- from there, and then create the real foundation.
65+
let mkFoundation appConnPool = App {..}
66+
tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
67+
logFunc = messageLoggerSource tempFoundation appLogger
68+
69+
-- Create the database connection pool
70+
pool <- flip runLoggingT logFunc $ createPostgresqlPool
71+
(pgConnStr $ appDatabaseConf appSettings)
72+
(pgPoolSize $ appDatabaseConf appSettings)
73+
74+
-- Perform database migration using our application's logging settings.
75+
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
76+
77+
-- Return the foundation
78+
return $ mkFoundation pool
79+
80+
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
81+
-- applyng some additional middlewares.
82+
makeApplication :: App -> IO Application
83+
makeApplication foundation = do
5084
logWare <- mkRequestLogger def
5185
{ outputFormat =
52-
if development
86+
if appDetailedRequestLogging $ appSettings foundation
5387
then Detailed True
54-
else Apache FromSocket
55-
, destination = RequestLogger.Logger $ loggerSet $ appLogger foundation
88+
else Apache
89+
(if appIpFromHeader $ appSettings foundation
90+
then FromFallback
91+
else FromSocket)
92+
, destination = Logger $ loggerSet $ appLogger foundation
5693
}
5794

5895
-- Create the WAI application and apply middlewares
59-
app <- toWaiAppPlain foundation
60-
return $ logWare app
61-
62-
-- | Loads up any necessary settings, creates your foundation datatype, and
63-
-- performs some initialization.
64-
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
65-
makeFoundation conf = do
66-
manager <- newManager conduitManagerSettings
67-
s <- staticSite
68-
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
69-
Database.Persist.loadConfig >>=
70-
Database.Persist.applyEnv
71-
p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf)
72-
73-
loggerSet' <- newStdoutLoggerSet defaultBufSize
74-
(getter, _) <- clockDateCacher
75-
76-
let logger = Yesod.Core.Types.Logger loggerSet' getter
77-
foundation = App conf s p manager dbconf logger
96+
appPlain <- toWaiAppPlain foundation
97+
return $ logWare $ defaultMiddlewaresNoLogging appPlain
7898

79-
-- Perform database migration using our application's logging settings.
80-
runLoggingT
81-
(Database.Persist.runPool dbconf (runMigration migrateAll) p)
82-
(messageLoggerSource foundation logger)
83-
84-
return foundation
85-
86-
-- for yesod devel
87-
getApplicationDev :: IO (Int, Application)
88-
getApplicationDev =
89-
defaultDevelApp loader makeApplication
90-
where
91-
loader = Yesod.Default.Config.loadConfig (configSettings Development)
92-
{ csParseExtra = parseExtra
93-
}
99+
-- | Warp settings for the given foundation value.
100+
warpSettings :: App -> Settings
101+
warpSettings foundation =
102+
setPort (appPort $ appSettings foundation)
103+
$ setHost (appHost $ appSettings foundation)
104+
$ setOnException (\_req e ->
105+
when (defaultShouldDisplayException e) $ messageLoggerSource
106+
foundation
107+
(appLogger foundation)
108+
$(qLocation >>= liftLoc)
109+
"yesod"
110+
LevelError
111+
(toLogStr $ "Exception from Warp: " ++ show e))
112+
defaultSettings
113+
114+
115+
116+
-- | For yesod devel, return the Warp settings and WAI Application.
117+
getApplicationDev :: IO (Settings, Application)
118+
getApplicationDev = do
119+
settings <- getAppSettings
120+
foundation <- makeFoundation settings
121+
wsettings <- getDevSettings $ warpSettings foundation
122+
app <- makeApplication foundation
123+
return (wsettings, app)
124+
125+
126+
getAppSettings :: IO AppSettings
127+
getAppSettings = loadAppSettings [configSettingsYml] [] useEnv
128+
129+
-- | main function for use by yesod devel
130+
develMain :: IO ()
131+
develMain = develMainHelper getApplicationDev
132+
133+
-- | The @main@ function for an executable running this site.
134+
appMain :: IO ()
135+
appMain = do
136+
-- Get the settings from all relevant sources
137+
settings <- loadAppSettingsArgs
138+
-- fall back to compile-time values, set to [] to require values at runtime
139+
[configSettingsYmlValue]
140+
141+
-- allow environment variables to override
142+
useEnv
143+
144+
-- Generate the foundation from the settings
145+
foundation <- makeFoundation settings
146+
147+
-- Generate a WAI Application from the foundation
148+
app <- makeApplication foundation
149+
150+
-- Run the application with Warp
151+
runSettings (warpSettings foundation) app
152+
--------------------------------------------------------------
153+
-- Functions for DevelMain.hs (a way to run the app from GHCi)
154+
--------------------------------------------------------------
155+
getApplicationRepl :: IO (Int, App, Application)
156+
getApplicationRepl = do
157+
settings <- getAppSettings
158+
foundation <- makeFoundation settings
159+
wsettings <- getDevSettings $ warpSettings foundation
160+
app1 <- makeApplication foundation
161+
return (getPort wsettings, foundation, app1)
162+
163+
shutdownApp :: App -> IO ()
164+
shutdownApp _ = return ()
165+
166+
167+
---------------------------------------------
168+
-- Functions for use in development with GHCi
169+
---------------------------------------------
170+
171+
-- | Run a handler
172+
handler :: Handler a -> IO a
173+
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
174+
175+
-- | Run DB queries
176+
db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a
177+
db = handler . runDB

0 commit comments

Comments
 (0)