]> Git — Sourcephile - comptalang.git/blob - web/Application.hs
Modif : null -> nil.
[comptalang.git] / web / Application.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Application
3 ( getApplicationDev
4 , appMain
5 , develMain
6 , makeFoundation
7 -- * for DevelMain
8 , getApplicationRepl
9 , shutdownApp
10 -- * for GHCI
11 , handler
12 , db
13 ) where
14
15 import Control.Monad.Logger (liftLoc, runLoggingT)
16 import Database.Persist.Sqlite (createSqlitePool, runSqlPool,
17 sqlDatabase, sqlPoolSize)
18 import Import
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)
30
31 -- Import all relevant handler modules here.
32 -- Don't forget to add new modules to your cabal file!
33 import Handler.Common
34 import Handler.Home
35
36 -- This line actually creates our YesodDispatch instance. It is the second half
37 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
38 -- comments there for more details.
39 mkYesodDispatch "App" resourcesApp
40
41 -- | This function allocates resources (such as a database connection pool),
42 -- performs initialization and return a foundation datatype value. This is also
43 -- the place to put your migrate statements to have automatic database
44 -- migrations handled by Yesod.
45 makeFoundation :: AppSettings -> IO App
46 makeFoundation appSettings = do
47 -- Some basic initializations: HTTP connection manager, logger, and static
48 -- subsite.
49 appHttpManager <- newManager
50 appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
51 appStatic <-
52 (if appMutableStatic appSettings then staticDevel else static)
53 (appStaticDir appSettings)
54
55 -- We need a log function to create a connection pool. We need a connection
56 -- pool to create our foundation. And we need our foundation to get a
57 -- logging function. To get out of this loop, we initially create a
58 -- temporary foundation without a real connection pool, get a log function
59 -- from there, and then create the real foundation.
60 let mkFoundation appConnPool = App {..}
61 tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
62 logFunc = messageLoggerSource tempFoundation appLogger
63
64 -- Create the database connection pool
65 pool <- flip runLoggingT logFunc $ createSqlitePool
66 (sqlDatabase $ appDatabaseConf appSettings)
67 (sqlPoolSize $ appDatabaseConf appSettings)
68
69 -- Perform database migration using our application's logging settings.
70 runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
71
72 -- Return the foundation
73 return $ mkFoundation pool
74
75 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
76 -- applyng some additional middlewares.
77 makeApplication :: App -> IO Application
78 makeApplication foundation = do
79 logWare <- mkRequestLogger def
80 { outputFormat =
81 if appDetailedRequestLogging $ appSettings foundation
82 then Detailed True
83 else Apache
84 (if appIpFromHeader $ appSettings foundation
85 then FromFallback
86 else FromSocket)
87 , destination = Logger $ loggerSet $ appLogger foundation
88 }
89
90 -- Create the WAI application and apply middlewares
91 appPlain <- toWaiAppPlain foundation
92 return $ logWare $ defaultMiddlewaresNoLogging appPlain
93
94 -- | Warp settings for the given foundation value.
95 warpSettings :: App -> Settings
96 warpSettings foundation =
97 setPort (appPort $ appSettings foundation)
98 $ setHost (appHost $ appSettings foundation)
99 $ setOnException (\_req e ->
100 when (defaultShouldDisplayException e) $ messageLoggerSource
101 foundation
102 (appLogger foundation)
103 $(qLocation >>= liftLoc)
104 "yesod"
105 LevelError
106 (toLogStr $ "Exception from Warp: " ++ show e))
107 defaultSettings
108
109 -- | For yesod devel, return the Warp settings and WAI Application.
110 getApplicationDev :: IO (Settings, Application)
111 getApplicationDev = do
112 settings <- getAppSettings
113 foundation <- makeFoundation settings
114 wsettings <- getDevSettings $ warpSettings foundation
115 app <- makeApplication foundation
116 return (wsettings, app)
117
118 getAppSettings :: IO AppSettings
119 getAppSettings = loadAppSettings [configSettingsYml] [] useEnv
120
121 -- | main function for use by yesod devel
122 develMain :: IO ()
123 develMain = develMainHelper getApplicationDev
124
125 -- | The @main@ function for an executable running this site.
126 appMain :: IO ()
127 appMain = do
128 -- Get the settings from all relevant sources
129 settings <- loadAppSettingsArgs
130 -- fall back to compile-time values, set to [] to require values at runtime
131 [configSettingsYmlValue]
132
133 -- allow environment variables to override
134 useEnv
135
136 -- Generate the foundation from the settings
137 foundation <- makeFoundation settings
138
139 -- Generate a WAI Application from the foundation
140 app <- makeApplication foundation
141
142 -- Run the application with Warp
143 runSettings (warpSettings foundation) app
144
145
146 --------------------------------------------------------------
147 -- Functions for DevelMain.hs (a way to run the app from GHCi)
148 --------------------------------------------------------------
149 getApplicationRepl :: IO (Int, App, Application)
150 getApplicationRepl = do
151 settings <- getAppSettings
152 foundation <- makeFoundation settings
153 wsettings <- getDevSettings $ warpSettings foundation
154 app1 <- makeApplication foundation
155 return (getPort wsettings, foundation, app1)
156
157 shutdownApp :: App -> IO ()
158 shutdownApp _ = return ()
159
160
161 ---------------------------------------------
162 -- Functions for use in development with GHCi
163 ---------------------------------------------
164
165 -- | Run a handler
166 handler :: Handler a -> IO a
167 handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
168
169 -- | Run DB queries
170 db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a
171 db = handler . runDB