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