forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Use forkFinally in ResultShare to be sure we always catch exceptions & set MVar

Browse source
This commit is contained in:
fr33domlover 2019-05-10 21:33:08 +00:00
parent f88dcef0d7
commit 48cfccd3d2
2 changed files with 11 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
src/Control/Concurrent/ResultShare.hs
View file

@ -42,6 +42,7 @@ import Prelude
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TVar
import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.STM import Control.Monad.STM
@ -51,7 +52,7 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
data ResultShare k v a = ResultShare 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 , _rsAction :: k -> a -> IO v
} }
@ -70,7 +71,11 @@ stateTVar var f = do
return a return a
runShared 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 runShared (ResultShare tvar action) key param = liftIO $ do
(mvar, new) <- do (mvar, new) <- do
existing <- M.lookup key <$> readTVarIO tvar existing <- M.lookup key <$> readTVarIO tvar
@ -82,8 +87,7 @@ runShared (ResultShare tvar action) key param = liftIO $ do
case M.lookup key m of case M.lookup key m of
Just v' -> ((v', False), m) Just v' -> ((v', False), m)
Nothing -> ((v , True) , M.insert key v m) Nothing -> ((v , True) , M.insert key v m)
when new $ void $ forkIO $ do when new $ void $ forkFinally (action key param) $ \ result -> do
result <- action key param
atomically $ modifyTVar' tvar $ M.delete key atomically $ modifyTVar' tvar $ M.delete key
putMVar mvar result putMVar mvar result
readMVar mvar readMVar mvar

6
src/Vervis/RemoteActorStore.hs
View file

@ -79,7 +79,7 @@ data RoomMode
= RoomModeInstant = RoomModeInstant
| RoomModeCached RoomModeDB | 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 class Yesod site => YesodRemoteActorStore site where
siteInstanceMutex :: site -> InstanceMutex siteInstanceMutex :: site -> InstanceMutex
@ -469,8 +469,8 @@ actorFetchShareAction
, PersistConfigPool (SitePersistConfig site) ~ ConnectionPool , PersistConfigPool (SitePersistConfig site) ~ ConnectionPool
, PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT , PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT
) )
=> FedURI -> (site, InstanceId) -> IO (Either SomeException (Either (Maybe APGetError) (Entity RemoteActor))) => FedURI -> (site, InstanceId) -> IO (Either (Maybe APGetError) (Entity RemoteActor))
actorFetchShareAction u (site, iid) = try $ flip runWorkerT site $ do actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
let (h, lu) = f2l u let (h, lu) = f2l u
mers <- runSiteDB $ getBy $ UniqueRemoteActor iid lu mers <- runSiteDB $ getBy $ UniqueRemoteActor iid lu
case mers of case mers of