-
Notifications
You must be signed in to change notification settings - Fork 2
/
Application.hs
155 lines (138 loc) · 5.13 KB
/
Application.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev
, appMain
, develMain
, makeFoundation
, makeLogWare
-- * for DevelMain
, getApplicationRepl
, shutdownApp
-- * for GHCI
, handler
, db
) where
import Control.Monad.Logger (liftLoc, runLoggingT)
import Database.Persist.Sql (runMigration)
import Database.Persist.Sqlite (createSqlitePool, runSqlPool, sqlDatabase, sqlPoolSize)
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException,
getPort, setHost, setOnException, setPort)
import Network.Wai.Handler.WarpTLS
import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..),
OutputFormat (..), destination,
mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
import Handler.Common
import Handler.Github
import Handler.Home
import Handler.Manager
import Handler.ManagerEdit
import Handler.ManagerNew
import Handler.Profile
import Handler.TutorialDelete
import Handler.TutorialEdit
import Handler.TutorialList
import Handler.TutorialR
import Handler.Tutorials
mkYesodDispatch "App" resourcesApp
makeFoundation :: AppSettings -> IO App
makeFoundation appSettings = do
appHttpManager <- newManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
let appGithubKeys =
OAuthKeys {oauthKeysClientId = "", oauthKeysClientSecret = ""}
appStatic <-
(if appMutableStatic appSettings
then staticDevel
else static)
(appStaticDir appSettings)
let mkFoundation appConnPool = App {..}
tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
logFunc = messageLoggerSource tempFoundation appLogger
pool <-
flip runLoggingT logFunc $
createSqlitePool
(sqlDatabase $ appDatabaseConf appSettings)
(sqlPoolSize $ appDatabaseConf appSettings)
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
return $ mkFoundation pool
makeApplication :: App -> IO Application
makeApplication foundation = do
logWare <- makeLogWare foundation
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
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
}
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
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 = loadYamlSettings [configSettingsYml] [] useEnv
develMain :: IO ()
develMain = develMainHelper getApplicationDev
-- SSL support
tlsS :: TLSSettings
tlsS =
tlsSettings
"/etc/letsencrypt/live/haskell-serbia.com/fullchain.pem"
"/etc/letsencrypt/live/haskell-serbia.com/privkey.pem"
appMain :: IO ()
appMain = do
settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv
foundation <- makeFoundation settings
app <- makeApplication foundation
runTLS tlsS (warpSettings foundation) app
--------------------------------------------------------------
-- 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