Vervis/src/Yesod/MonadSite.hs

{- This file is part of Vervis.
 -
 - Written in 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/>.
 -}

-- | A typeclass providing a subset of what 'HandlerFor' does, allowing to
-- write monadic actions that can run both inside a request handler and outside
-- of the web server context.
module Yesod.MonadSite
    ( Site (..)
    , MonadSite (..)
    , asksSite
    , runSiteDB
    , WorkerT ()
    , runWorkerT
    , WorkerFor
    , runWorker
    )
where

import Prelude

import Control.Exception
import Control.Monad.Fail
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Functor
import Data.Text (Text)
import Database.Persist.Sql
import UnliftIO.Async
import UnliftIO.Concurrent
import Yesod.Core
import Yesod.Core.Types
import Yesod.Persist.Core

class PersistConfig (SitePersistConfig site) => Site site where
    type SitePersistConfig site
    siteApproot       :: site -> Text
    sitePersistConfig :: site -> SitePersistConfig site
    sitePersistPool   :: site -> PersistConfigPool (SitePersistConfig site)
    siteLogger        :: site -> Logger

class (MonadUnliftIO m, MonadLogger m) => MonadSite m where
    type SiteEnv m
    askSite      :: m (SiteEnv m)
    askUrlRender :: m (Route (SiteEnv m) -> Text)
    forkSite     :: (SomeException -> m ()) -> m () -> m ()
    asyncSite    :: m a -> m (m (Either SomeException a))

asksSite :: MonadSite m => (SiteEnv m -> a) -> m a
asksSite f = f <$> askSite

runSiteDB
    :: (MonadSite m, Site (SiteEnv m))
    => PersistConfigBackend (SitePersistConfig (SiteEnv m)) m a
    -> m a
runSiteDB action = do
    site <- askSite
    runPool (sitePersistConfig site) action (sitePersistPool site)

instance MonadSite (HandlerFor site) where
    type SiteEnv (HandlerFor site) = site
    askSite = getYesod
    askUrlRender = getUrlRender
    forkSite = forkHandler
    asyncSite action = do
        mvar <- newEmptyMVar
        let handle e = putMVar mvar $ Left e
        forkHandler handle $ do
            result <- action
            putMVar mvar $ Right result
        return $ liftIO $ readMVar mvar

newtype WorkerT site m a = WorkerT
    { unWorkerT :: LoggingT (ReaderT site m) a
    }
    deriving
        ( Functor, Applicative, Monad, MonadFail, MonadIO, MonadLogger
        , MonadLoggerIO
        )

instance MonadUnliftIO m => MonadUnliftIO (WorkerT site m) where
    askUnliftIO =
        WorkerT $ withUnliftIO $ \ u ->
            return $ UnliftIO $ unliftIO u . unWorkerT
    withRunInIO inner =
        WorkerT $ withRunInIO $ \ run -> inner (run . unWorkerT)

instance MonadTrans (WorkerT site) where
    lift = WorkerT . lift . lift

instance (MonadUnliftIO m, Yesod site, Site site) => MonadSite (WorkerT site m) where
    type SiteEnv (WorkerT site m) = site
    askSite = WorkerT $ lift ask
    askUrlRender = do
        site <- askSite
        return $ \ route -> yesodRender site (siteApproot site) route []
    forkSite handler action = void $ forkFinally action handler'
        where
        handler' (Left e)  = handler e
        handler' (Right _) = pure ()
    asyncSite action = waitCatch <$> async action

runWorkerT :: (Yesod site, Site site) => WorkerT site m a -> site -> m a
runWorkerT (WorkerT action) site = runReaderT (runLoggingT action logFunc) site
    where
    logFunc = messageLoggerSource site (siteLogger site)

type WorkerFor site = WorkerT site IO

runWorker :: (Yesod site, Site site) => WorkerFor site a -> site -> IO a
runWorker = runWorkerT