fradrive/src/Application.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
    ( getApplicationDev, getAppDevSettings
    , appMain
    , develMain
    , makeFoundation
    , makeLogWare
    -- * for DevelMain
    , foundationStoreNum
    , getApplicationRepl
    , shutdownApp
    -- * for GHCI
    , handler
    , db
    , addPWEntry
    ) where

import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                             pgPoolSize, runSqlPool)
import Import
import Language.Haskell.TH.Syntax           (qLocation)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp             (Settings, defaultSettings,
                                             defaultShouldDisplayException,
                                             runSettings, setHost,
                                             setOnException, setPort, getPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
                                             IPAddrSource (..),
                                             OutputFormat (..), destination,
                                             mkRequestLogger, outputFormat)
import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                             toLogStr)

import Foreign.Store

import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID

import System.Directory
import System.FilePath

import Jobs

import qualified Data.Text.Encoding as Text
import Yesod.Auth.Util.PasswordStore

import qualified Data.ByteString.Lazy as LBS

import Network.HaskellNet.SSL hiding (Settings)
import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
import Data.Pool

import Control.Monad.Trans.Resource

import System.Log.FastLogger.Date
import qualified Yesod.Core.Types as Yesod (Logger(..))

import qualified Data.HashMap.Strict as HashMap

import Control.Lens ((&))
  
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.Common
import Handler.Home
import Handler.Profile
import Handler.Users
import Handler.Admin
import Handler.Term
import Handler.School
import Handler.Course
import Handler.Sheet
import Handler.Submission
import Handler.Corrections
import Handler.CryptoIDDispatch
import Handler.SystemMessage


-- 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 "UniWorX" resourcesUniWorX

-- | 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 :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
makeFoundation appSettings@(AppSettings{..}) = do
    -- Some basic initializations: HTTP connection manager, logger, and static
    -- subsite.
    appHttpManager <- newManager
    appLogger <- liftIO $ do
      tgetter <- newTimeCache "%Y-%m-%d %T %z"
      loggerSet <- newStdoutLoggerSet defaultBufSize
      return $ Yesod.Logger loggerSet tgetter
    appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir

    appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
    appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile

    (appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do
        chan <- newBroadcastTMChan
        recvChan <- dupTMChan chan
        return (chan, recvChan)

    appLogSettings <- liftIO $ newTVarIO appInitialLogSettings

    -- We need a log function to create a connection pool. We need a connection
    -- pool to create our foundation. And we need our foundation to get a
    -- logging function. To get out of this loop, we initially create a
    -- temporary foundation without a real connection pool, get a log function
    -- from there, and then create the real foundation.
    let mkFoundation appConnPool appSmtpPool = UniWorX {..}
        -- The UniWorX {..} syntax is an example of record wild cards. For more
        -- information, see:
        -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
        tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation")
        logFunc = messageLoggerSource tempFoundation appLogger

    flip runLoggingT logFunc $ do
      $logDebugS "InstanceID" $ UUID.toText appInstanceID
      -- $logDebugS "Configuration" $ tshow appSettings

      smtpPool <- traverse createSmtpPool appSmtpConf

      -- Create the database connection pool
      sqlPool <- createPostgresqlPool
        (pgConnStr  appDatabaseConf)
        (pgPoolSize appDatabaseConf)
    
      -- Perform database migration using our application's logging settings.
      migrateAll `runSqlPool` sqlPool

      handleJobs recvChans $ mkFoundation sqlPool smtpPool

      -- Return the foundation
      return $ mkFoundation sqlPool smtpPool

readInstanceIDFile :: MonadIO m => FilePath -> m UUID
readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
  where
    parseBS :: LBS.ByteString -> IO UUID
    parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString
    generateInstead :: IOException -> IO UUID
    generateInstead e
      | isDoesNotExistError e = do
          createDirectoryIfMissing True $ takeDirectory idFile
          instanceId <- UUID.nextRandom
          LBS.writeFile idFile $ UUID.toByteString instanceId
          return instanceId
      | otherwise = throw e

createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
  logFunc <- askLoggerIO
  let
    withLogging :: LoggingT IO a -> IO a
    withLogging = flip runLoggingT logFunc
    
    mkConnection = withLogging $ do
      $logInfoS "SMTP" "Opening new connection"
      liftIO mkConnection'
    mkConnection'
      | SmtpSslNone <- smtpSsl = connectSMTPPort smtpHost smtpPort
      | SmtpSslSmtps <- smtpSsl = connectSMTPSSLWithSettings smtpHost $ defaultSettingsWithPort smtpPort
      | SmtpSslStarttls <- smtpSsl = connectSMTPSTARTTLSWithSettings smtpHost $ defaultSettingsWithPort smtpPort
    reapConnection conn = withLogging $ do
      $logDebugS "SMTP" "Closing connection"
      liftIO $ closeSMTP conn
    applyAuth :: SmtpAuthConf -> SMTPConnection -> IO SMTPConnection
    applyAuth SmtpAuthConf{..} conn = withLogging $ do
      $logDebugS "SMTP" "Doing authentication"
      authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn
      when (not authSuccess) $ do
        fail "SMTP authentication failed"
      return conn
  liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit

-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: MonadIO m => UniWorX -> m Application
makeApplication foundation = liftIO $ do
    logWare <- makeLogWare foundation
    -- Create the WAI application and apply middlewares
    appPlain <- toWaiAppPlain foundation
    return $ logWare $ defaultMiddlewaresNoLogging appPlain

makeLogWare :: MonadIO m => UniWorX -> m Middleware
makeLogWare app = do
  logWareMap <- liftIO $ newTVarIO HashMap.empty

  let
    mkLogWare ls@LogSettings{..} = do
      logWare <- mkRequestLogger def
        { outputFormat = bool
            (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
            (Detailed True)
            logDetailed
        , destination = Logger . loggerSet $ appLogger app
        }
      atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
      return logWare

  void. liftIO $
    mkLogWare =<< readTVarIO (appLogSettings app)

  return $ \wai req fin -> do
    lookupRes <- atomically $ do
      ls <- readTVar $ appLogSettings app
      existing <- HashMap.lookup ls <$> readTVar logWareMap
      return $ maybe (Left ls) Right existing
    logWare <- either mkLogWare return lookupRes
    logWare wai req fin

-- | Warp settings for the given foundation value.
warpSettings :: UniWorX -> Settings
warpSettings foundation = defaultSettings
    & 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))

-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application)
getApplicationDev = do
    settings <- getAppDevSettings
    foundation <- makeFoundation settings
    wsettings <- liftIO . getDevSettings $ warpSettings foundation
    app <- makeApplication foundation
    return (wsettings, app)

getAppDevSettings :: MonadIO m => m AppSettings
getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv

-- | main function for use by yesod devel
develMain :: IO ()
develMain = runResourceT $
  liftIO . develMainHelper . return =<< getApplicationDev

-- | The @main@ function for an executable running this site.
appMain :: MonadResourceBase m => m ()
appMain = runResourceT $ do
    -- Get the settings from all relevant sources
    settings <- liftIO $
      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
    liftIO $ runSettings (warpSettings foundation) app


--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
foundationStoreNum :: Word32
foundationStoreNum = 2
  
getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
getApplicationRepl = do
    settings <- getAppDevSettings
    foundation <- makeFoundation settings
    wsettings <- liftIO . getDevSettings $ warpSettings foundation
    app1 <- makeApplication foundation

    let foundationStore = Store foundationStoreNum
    liftIO $ deleteStore foundationStore
    liftIO $ writeStore foundationStore foundation
  
    return (getPort wsettings, foundation, app1)

shutdownApp :: MonadIO m => UniWorX -> m ()
shutdownApp UniWorX{..} = do
  liftIO . atomically $ mapM_ closeTMChan appJobCtl


---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------

-- | Run a handler
handler :: Handler a -> IO a
handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h

-- | Run DB queries
db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
db = handler . runDB

addPWEntry :: User
           -> Text {-^ Password -}
           -> IO ()
addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
  PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
  void $ insert User{..}