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