From 48cfccd3d247d8d37d3796cc547cc80d5367fec7 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Fri, 10 May 2019 21:33:08 +0000
Subject: [PATCH] Use forkFinally in ResultShare to be sure we always catch
 exceptions & set MVar

---
 src/Control/Concurrent/ResultShare.hs | 12 ++++++++----
 src/Vervis/RemoteActorStore.hs        |  6 +++---
 2 files changed, 11 insertions(+), 7 deletions(-)

diff --git a/src/Control/Concurrent/ResultShare.hs b/src/Control/Concurrent/ResultShare.hs
index 55f8eea..5998aec 100644
--- a/src/Control/Concurrent/ResultShare.hs
+++ b/src/Control/Concurrent/ResultShare.hs
@@ -42,6 +42,7 @@ import Prelude
 
 import Control.Concurrent
 import Control.Concurrent.STM.TVar
+import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.STM
@@ -51,7 +52,7 @@ import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as M
 
 data ResultShare k v a = ResultShare
-    { _rsMap    :: TVar (HashMap k (MVar v))
+    { _rsMap    :: TVar (HashMap k (MVar (Either SomeException v)))
     , _rsAction :: k -> a -> IO v
     }
 
@@ -70,7 +71,11 @@ stateTVar var f = do
     return a
 
 runShared
-    :: (MonadIO m, Eq k, Hashable k) => ResultShare k v a -> k -> a -> m v
+    :: (MonadIO m, Eq k, Hashable k)
+    => ResultShare k v a
+    -> k
+    -> a
+    -> m (Either SomeException v)
 runShared (ResultShare tvar action) key param = liftIO $ do
     (mvar, new) <- do
         existing <- M.lookup key <$> readTVarIO tvar
@@ -82,8 +87,7 @@ runShared (ResultShare tvar action) key param = liftIO $ do
                     case M.lookup key m of
                         Just v' -> ((v', False), m)
                         Nothing -> ((v , True) , M.insert key v m)
-    when new $ void $ forkIO $ do
-        result <- action key param
+    when new $ void $ forkFinally (action key param) $ \ result -> do
         atomically $ modifyTVar' tvar $ M.delete key
         putMVar mvar result
     readMVar mvar
diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs
index c17db26..91bdc64 100644
--- a/src/Vervis/RemoteActorStore.hs
+++ b/src/Vervis/RemoteActorStore.hs
@@ -79,7 +79,7 @@ data RoomMode
     = RoomModeInstant
     | RoomModeCached RoomModeDB
 
-type ActorFetchShare site = ResultShare FedURI (Either SomeException (Either (Maybe APGetError) (Entity RemoteActor))) (site, InstanceId)
+type ActorFetchShare site = ResultShare FedURI (Either (Maybe APGetError) (Entity RemoteActor)) (site, InstanceId)
 
 class Yesod site => YesodRemoteActorStore site where
     siteInstanceMutex    :: site -> InstanceMutex
@@ -469,8 +469,8 @@ actorFetchShareAction
        , PersistConfigPool (SitePersistConfig site) ~ ConnectionPool
        , PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT
        )
-    => FedURI -> (site, InstanceId) -> IO (Either SomeException (Either (Maybe APGetError) (Entity RemoteActor)))
-actorFetchShareAction u (site, iid) = try $ flip runWorkerT site $ do
+    => FedURI -> (site, InstanceId) -> IO (Either (Maybe APGetError) (Entity RemoteActor))
+actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
     let (h, lu) = f2l u
     mers <- runSiteDB $ getBy $ UniqueRemoteActor iid lu
     case mers of