Application.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Application
  ( getApplicationDev
  , appMain
  , develMain
  , makeFoundation
  , makeLogWare
    -- * for DevelMain
  , getApplicationRepl
  , shutdownApp
    -- * for GHCI
  , handler
  ) where

import qualified Calendar as Cal
import           Control.Monad.Logger                   (logInfoN, liftLoc)
import qualified FreshCache as FC
import           Import
import           Language.Haskell.TH.Syntax             (qLocation)
import Data.Time.Clock (NominalDiffTime)
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)

-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import           Handler.Common
import           Handler.Home

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

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

-- | 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
makeFoundation appSettings@AppSettings{..} = do
  appHttpManager <- getGlobalManager
  appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
  appStatic <-
    (if appMutableStatic then staticDevel else static) appStaticDir
  let
    partialApp = App{..}
      where
        appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
        appGetCalendar = error "partialApp loop: Accessing appGetCalendar"
    logFunc loc src lv =
      whenM (shouldLogIO partialApp "" lv) .
      messageLoggerSource partialApp appLogger loc src lv
  appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
  cache <- unsafeHandler partialApp $ FC.newCache $ do
    logInfoN "Refreshing calendar cache"
    Cal.listAvailMinusBusy appCalendarCxt
      appFreeCalendarId appBusyCalendarId $ fromWeeks appLookaheadWeeks
  let appGetCalendar = FC.readCache cache . fromMaybe appCacheExpiry
  return App {..}

-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
  logWare <- makeLogWare foundation
    -- Create the WAI application and apply middlewares
  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
      }

-- | Warp settings for the given foundation value.
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

-- | For yesod devel, return the Warp settings and WAI Application.
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

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

-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain
    -- Get the settings from all relevant sources
 = do
  settings <-
    loadYamlSettingsArgs
        -- fall back to compile-time values, set to [] to require values at runtime
      [configSettingsYmlValue]
        -- allow environment variables to override
      useEnv
    -- Generate the foundation from the settings
  foundation <- makeFoundation settings
    -- Generate a WAI Application from the foundation
  app <- makeApplication foundation
    -- Run the application with Warp
  runSettings (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