From 6df2200f4778c4a48351a843eef1b8b7a7c34a99 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Fri, 14 Jun 2019 17:10:12 +0000
Subject: [PATCH] Yesod.MonadSite module gets some nice upgrades

- Fork and async are no longer class methods, which simplifies things a lot and
  allows for many more trivial instances, much like with MonadHandler. Fork and
  async are still available, but instead of unnecessarily being class methods,
  they are now provided as follows: You can fork and async a worker (no more
  fork/async for handler, because I never actually need that, and not sure
  there's ever a need for that in general), and you can do that from any
  MonadSite. So, you can fork or async a worker from a Handler, from a Worker,
  from a ReaderT on top of them e.g. inside runDB, and so on.
- Following the simplification, new MonadSite instances are provided, so far
  just the ones in actual use in the code. ReaderT, ExceptT and lazy RWST. More
  can be added easily. Oh, and WidgetFor got an instance too.

In particular, this change means there's no usage of `forkHandler` anymore, at
all. I wonder if it ever makes a difference to `forkWorker` versus
`forkHandler`. Like, does it cause memory leaks or anything. I guess could
check why `forkResource` etc. is good for in `forkHandler` implementation. I
suppose if needed, I could fix possible memory leaks in `forkWorker`.
---
 src/Vervis/Federation.hs |  2 +-
 src/Yesod/MonadSite.hs   | 41 ++++++++++++++++++++++++++++++++++++++--
 2 files changed, 40 insertions(+), 3 deletions(-)

diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index 2f442db..b13e2af 100644
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@@ -1903,7 +1903,7 @@ retryOutboxDelivery = do
         = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
         . groupWithExtractBy ((==) `on` fst) fst snd
     fork action = do
-        wait <- asyncSite action
+        wait <- asyncWorker action
         return $ do
             result <- wait
             case result of
diff --git a/src/Yesod/MonadSite.hs b/src/Yesod/MonadSite.hs
index 867a665..a1b1062 100644
--- a/src/Yesod/MonadSite.hs
+++ b/src/Yesod/MonadSite.hs
@@ -26,6 +26,7 @@ module Yesod.MonadSite
     , WorkerFor
     , runWorker
     , forkWorker
+    , asyncWorker
     )
 where
 
@@ -37,6 +38,7 @@ import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
 import Data.Functor
 import Data.Text (Text)
@@ -47,6 +49,7 @@ import Yesod.Core hiding (logError)
 import Yesod.Core.Types
 import Yesod.Persist.Core
 
+import qualified Control.Monad.Trans.RWS.Lazy as RWSL
 import qualified Data.Text as T
 
 class PersistConfig (SitePersistConfig site) => Site site where
@@ -56,18 +59,35 @@ class PersistConfig (SitePersistConfig site) => Site site where
     sitePersistPool   :: site -> PersistConfigPool (SitePersistConfig site)
     siteLogger        :: site -> Logger
 
-class (MonadUnliftIO m, MonadLogger m) => MonadSite m where
+class (MonadIO 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))
+    -}
+
+instance MonadSite m => MonadSite (ReaderT r m) where
+    type SiteEnv (ReaderT r m) = SiteEnv m
+    askSite                    = lift askSite
+    askUrlRender               = lift askUrlRender
+
+instance MonadSite m => MonadSite (ExceptT e m) where
+    type SiteEnv (ExceptT e m) = SiteEnv m
+    askSite                    = lift askSite
+    askUrlRender               = lift askUrlRender
+
+instance (Monoid w, MonadSite m) => MonadSite (RWSL.RWST r w s m) where
+    type SiteEnv (RWSL.RWST r w s m) = SiteEnv m
+    askSite                          = lift askSite
+    askUrlRender                     = lift askUrlRender
 
 asksSite :: MonadSite m => (SiteEnv m -> a) -> m a
 asksSite f = f <$> askSite
 
 runSiteDB
-    :: (MonadSite m, Site (SiteEnv m))
+    :: (MonadUnliftIO m, MonadSite m, Site (SiteEnv m))
     => PersistConfigBackend (SitePersistConfig (SiteEnv m)) m a
     -> m a
 runSiteDB action = do
@@ -78,6 +98,7 @@ instance MonadSite (HandlerFor site) where
     type SiteEnv (HandlerFor site) = site
     askSite = getYesod
     askUrlRender = getUrlRender
+    {-
     forkSite = forkHandler
     asyncSite action = do
         mvar <- newEmptyMVar
@@ -86,6 +107,12 @@ instance MonadSite (HandlerFor site) where
             result <- action
             putMVar mvar $ Right result
         return $ liftIO $ readMVar mvar
+    -}
+
+instance MonadSite (WidgetFor site) where
+    type SiteEnv (WidgetFor site) = site
+    askSite = getYesod
+    askUrlRender = getUrlRender
 
 newtype WorkerT site m a = WorkerT
     { unWorkerT :: LoggingT (ReaderT site m) a
@@ -111,11 +138,13 @@ instance (MonadUnliftIO m, Yesod site, Site site) => MonadSite (WorkerT site m)
     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
@@ -143,3 +172,11 @@ forkWorker err worker = do
                     "Worker thread threw exception: " <> err <> ": " <>
                     T.pack (displayException e)
             Right _ -> return ()
+
+asyncWorker
+    :: (MonadSite m, SiteEnv m ~ site, Yesod site, Site site)
+    => WorkerFor site a
+    -> m (m (Either SomeException a))
+asyncWorker worker = do
+    site <- askSite
+    liftIO $ waitCatch <$> async (runWorker worker site)