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