vervis/src/Vervis/Application.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# OPTIONS_GHC -fno-warn-orphans #-}

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

import Control.Monad.Logger                 (liftLoc, runLoggingT, logInfo, logError)
import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                             pgPoolSize, runSqlPool)
import Graphics.SVGFonts.Fonts (lin2)
import Graphics.SVGFonts.ReadFont (loadFont)
import Vervis.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 Yesod.Default.Main                   (LogFunc)
import Yesod.Mail.Send (runMailer)

import qualified Data.Text as T (unpack)

import Control.Concurrent.Local (forkCheck)

import Vervis.ActorKey (generateActorKey, actorKeyRotator)

-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Vervis.Handler.Common
import Vervis.Handler.Git
import Vervis.Handler.Group
import Vervis.Handler.Home
import Vervis.Handler.Key
import Vervis.Handler.Person
import Vervis.Handler.Project
import Vervis.Handler.Repo
import Vervis.Handler.Role
import Vervis.Handler.Sharer
import Vervis.Handler.Ticket
import Vervis.Handler.Wiki
import Vervis.Handler.Workflow

import Vervis.Migration (migrateDB)
import Vervis.Ssh (runSsh)

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

loggingFunction :: App -> LogFunc
loggingFunction app = messageLoggerSource app (appLogger app)

-- | 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 = do
    -- Some basic initializations: HTTP connection manager, logger, and static
    -- subsite.
    --appHttpManager <- newManager tlsManagerSettings
    appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
    appStatic <-
        (if appMutableStatic appSettings then staticDevel else static)
        (appStaticDir appSettings)

    appMailQueue <-
        case appMail appSettings of
            Nothing -> return Nothing
            Just _  -> Just <$> newChan

    appSvgFont <-
        if appLoadFontFromLibData appSettings
            then lin2
            else loadFont "data/LinLibertineCut.svg"

    appActorKey <- newTVarIO =<< generateActorKey

    -- 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 = App {..}
        -- The App {..} 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"
        logFunc = loggingFunction tempFoundation

    -- Create the database connection pool
    pool <- flip runLoggingT logFunc $ createPostgresqlPool
        (pgConnStr  $ appDatabaseConf appSettings)
        (pgPoolSize $ appDatabaseConf appSettings)

    -- Perform database migration using our application's logging settings.
    --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
    flip runLoggingT logFunc $
        flip runSqlPool pool $ do
            r <- migrateDB
            case r of
                Left err -> do
                    let msg = "DB migration failed: " <> err
                    $logError msg
                    error $ T.unpack msg
                Right (_from, _to) -> $logInfo "DB migration success"

    -- Return the foundation
    return $ mkFoundation pool

-- | 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) $ loggingFunction
            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 = loadAppSettings [configSettingsYml] [] useEnv

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

actorKeyPeriodicRotator :: App -> IO ()
actorKeyPeriodicRotator app =
    actorKeyRotator (appActorKeyRotation $ appSettings app) (appActorKey app)

sshServer :: App -> IO ()
sshServer foundation =
    runSsh
        (appSettings foundation)
        (appConnPool foundation)
        (loggingFunction foundation)

mailer :: App -> IO ()
mailer foundation =
    case (appMail $ appSettings foundation, appMailQueue foundation) of
        (Nothing  , Nothing)    -> return ()
        (Nothing  , Just _)     -> error "Mail queue unnecessarily created"
        (Just _   , Nothing)    -> error "Mail queue wasn't created"
        (Just mail, Just queue) ->
            runMailer
                mail
            --  (appConnPool foundation)
                (loggingFunction foundation)
                (readChan queue)

-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
    -- Get the settings from all relevant sources
    settings <- loadAppSettingsArgs
        -- 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 actor signature key periodic generation thread
    forkCheck $ actorKeyPeriodicRotator foundation

    -- Run SSH server
    forkCheck $ sshServer foundation

    -- Run mailer if SMTP is enabled
    forkCheck $ mailer 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

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