Application.hs 6.93 KB
Newer Older
1
{-# LANGUAGE MultiParamTypeClasses #-}
2
3
4
5
6
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
7
{-# LANGUAGE ViewPatterns          #-}
8
{-# OPTIONS_GHC -fno-warn-orphans #-}
9

10
module Application
11
12
13
14
15
  ( getApplicationDev
  , appMain
  , develMain
  , makeFoundation
  , makeLogWare
16
    -- * for DevelMain
17
18
  , getApplicationRepl
  , shutdownApp
19
    -- * for GHCI
20
21
22
  , handler
  ) where

23
import qualified Calendar as Cal
24
25
import           Control.Monad.Logger                   (logInfoN, liftLoc)
import qualified FreshCache as FC
26
27
import           Import
import           Language.Haskell.TH.Syntax             (qLocation)
28
import Data.Time.Clock (NominalDiffTime)
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
import           Network.HTTP.Client.TLS                (getGlobalManager)
import           Network.Wai                            (Middleware)
import           Network.Wai.Handler.Warp               (Settings,
                                                         defaultSettings,
                                                         defaultShouldDisplayException,
                                                         getPort, runSettings,
                                                         setHost,
                                                         setOnException,
                                                         setPort)
import           Network.Wai.Middleware.RequestLogger   (Destination (Logger),
                                                         IPAddrSource (..),
                                                         OutputFormat (..),
                                                         destination,
                                                         mkRequestLogger,
                                                         outputFormat)
import           System.Log.FastLogger                  (defaultBufSize,
                                                         newStdoutLoggerSet,
                                                         toLogStr)

48
49
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
50
51
import           Handler.Common
import           Handler.Home
52
53
54
55
56
57

-- 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

58
59
60
fromWeeks :: Int -> NominalDiffTime
fromWeeks w = 24 * 7 * 60 * 60 * fromIntegral w

61
62
63
64
65
-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App
66
makeFoundation appSettings@AppSettings{..} = do
67
68
69
  appHttpManager <- getGlobalManager
  appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
  appStatic <-
70
    (if appMutableStatic then staticDevel else static) appStaticDir
71
  let
72
73
    partialApp = App{..}
      where
74
75
        appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
        appGetCalendar = error "partialApp loop: Accessing appGetCalendar"
76
77
78
    logFunc loc src lv =
      whenM (shouldLogIO partialApp "" lv) .
      messageLoggerSource partialApp appLogger loc src lv
79
  appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
80
  cache <- unsafeHandler partialApp $ FC.newCache $ do
81
82
    logInfoN "Refreshing calendar cache"
    Cal.listAvailMinusBusy appCalendarCxt
83
84
      appFreeCalendarId appBusyCalendarId $ fromWeeks appLookaheadWeeks
  let appGetCalendar = FC.readCache cache . fromMaybe appCacheExpiry
85
  return App {..}
86
87
88
89
90

-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
91
  logWare <- makeLogWare foundation
92
    -- Create the WAI application and apply middlewares
93
94
  appPlain <- toWaiAppPlain foundation
  return $ logWare $ defaultMiddlewaresNoLogging appPlain
95
96
97

makeLogWare :: App -> IO Middleware
makeLogWare foundation =
98
99
100
101
102
103
104
105
106
107
108
  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
      }
109
110
111
112

-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings foundation =
113
114
115
116
117
118
119
120
121
122
123
124
125
  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
126
127
128
129

-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
130
131
132
133
134
  settings <- getAppSettings
  foundation <- makeFoundation settings
  wsettings <- getDevSettings $ warpSettings foundation
  app <- makeApplication foundation
  return (wsettings, app)
135
136
137
138
139
140
141
142
143
144

getAppSettings :: IO AppSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv

-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev

-- | The @main@ function for an executable running this site.
appMain :: IO ()
145
appMain
146
    -- Get the settings from all relevant sources
147
148
149
 = do
  settings <-
    loadYamlSettingsArgs
150
        -- fall back to compile-time values, set to [] to require values at runtime
151
      [configSettingsYmlValue]
152
        -- allow environment variables to override
153
      useEnv
154
    -- Generate the foundation from the settings
155
  foundation <- makeFoundation settings
156
    -- Generate a WAI Application from the foundation
157
  app <- makeApplication foundation
158
    -- Run the application with Warp
159
  runSettings (warpSettings foundation) app
160
161
162
163
164
165

--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
getApplicationRepl :: IO (Int, App, Application)
getApplicationRepl = do
166
167
168
169
170
  settings <- getAppSettings
  foundation <- makeFoundation settings
  wsettings <- getDevSettings $ warpSettings foundation
  app1 <- makeApplication foundation
  return (getPort wsettings, foundation, app1)
171
172
173
174
175
176
177
178
179
180

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