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.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
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 qualified Data.HashMap.Strict as M (empty)

import Database.Persist.Schema.PostgreSQL (schemaBackend)

import Control.Concurrent.ResultShare
import Data.KeyFile
import Yesod.MonadSite

import Control.Concurrent.Local
import Web.Hashids.Local

import Vervis.ActorKey (generateActorKey, actorKeyRotator)
import Vervis.Federation
import Vervis.KeyFile (isInitialSetup)
import Vervis.RemoteActorStore

-- 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.Inbox
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"

    appActorKeys <-
        newTVarIO =<<
        (,,) <$> generateActorKey <*> generateActorKey <*> pure True

    appInstanceMutex <- newInstanceMutex

    appActorFetchShare <- newResultShare actorFetchShareAction

    appActivities <-
        case appInboxDebugReportLength appSettings of
            Nothing -> return Nothing
            Just n -> Just . (n,) <$> newTVarIO mempty

    -- 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
            appCapSignKey
            appHashidsContext =
                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")
                (error "capSignKey forced in tempFoundation")
                (error "hashidsContext forced in tempFoundation")
        logFunc = loggingFunction tempFoundation

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

    setup <- isInitialSetup pool schemaBackend
    loadMode <- determineKeyFileLoadMode setup

    capSignKey <- loadKeyFile loadMode $ appCapabilitySigningKeyFile appSettings
    hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings
    let hashidsCtx = hashidsContext hashidsSalt

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

    -- Return the foundation
    return $ mkFoundation pool capSignKey hashidsCtx

-- | 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 = loadYamlSettings [configSettingsYml] [] useEnv

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

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

deliveryRunner :: App -> IO ()
deliveryRunner app =
    let interval = appDeliveryRetryFreq $ appSettings app
    in  runWorker (periodically interval retryOutboxDelivery) 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 <- 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 actor signature key periodic generation thread
    forkCheck $ actorKeyPeriodicRotator foundation

    -- Run periodic activity delivery retry runner
    when (appFederation $ appSettings foundation) $
        forkCheck $ deliveryRunner 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 (HandlerFor App) a -> IO a
db = handler . runDB