1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-03-20 15:14:54 +09:00

Run the delivery worker priodically, settings control how often to run

This commit is contained in:
fr33domlover 2019-04-18 10:38:01 +00:00
parent c9c7da5902
commit f37b9b3f52
12 changed files with 285 additions and 109 deletions
src/Control/Concurrent

View file

@ -15,13 +15,17 @@
module Control.Concurrent.Local
( forkCheck
, periodically
)
where
import Prelude
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Functor (void)
import Data.Time.Interval
-- | Like 'forkIO', but if the new thread terminates with an exception,
-- re-throw it in the current thread.
@ -29,3 +33,12 @@ forkCheck :: IO () -> IO ()
forkCheck run = do
tid <- myThreadId
void $ forkFinally run $ either (throwTo tid) (const $ return ())
periodically :: MonadIO m => TimeInterval -> m () -> m ()
periodically interval action =
let micros = microseconds interval
in if 0 < micros && micros <= toInteger (maxBound :: Int)
then
let micros' = fromInteger micros
in forever $ liftIO (threadDelay micros') >> action
else error $ "periodically: interval out of range: " ++ show micros

View file

@ -32,8 +32,7 @@
-- * It could be nice to provide defaults for plain IO and for UnliftIO
-- * The action is constant, could make it more flexible
module Control.Concurrent.ResultShare
( ResultShareSettings (..)
, ResultShare ()
( ResultShare ()
, newResultShare
, runShared
)
@ -41,7 +40,7 @@ where
import Prelude
import Control.Concurrent.MVar
import Control.Concurrent
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.IO.Class
@ -51,22 +50,16 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
data ResultShareSettings m k v a = ResultShareSettings
{ resultShareFork :: m () -> m ()
, resultShareAction :: k -> a -> m v
}
data ResultShare m k v a = ResultShare
data ResultShare k v a = ResultShare
{ _rsMap :: TVar (HashMap k (MVar v))
, _rsFork :: m () -> m ()
, _rsAction :: k -> a -> m v
, _rsAction :: k -> a -> IO v
}
newResultShare
:: MonadIO n => ResultShareSettings m k v a -> n (ResultShare m k v a)
newResultShare (ResultShareSettings fork action) = do
:: MonadIO m => (k -> a -> IO v) -> m (ResultShare k v a)
newResultShare action = do
tvar <- liftIO $ newTVarIO M.empty
return $ ResultShare tvar fork action
return $ ResultShare tvar action
-- TODO this is copied from stm-2.5, remove when we upgrade LTS
stateTVar :: TVar s -> (s -> (a, s)) -> STM a
@ -77,9 +70,9 @@ stateTVar var f = do
return a
runShared
:: (MonadIO m, Eq k, Hashable k) => ResultShare m k v a -> k -> a -> m v
runShared (ResultShare tvar fork action) key param = do
(mvar, new) <- liftIO $ do
:: (MonadIO m, Eq k, Hashable k) => ResultShare k v a -> k -> a -> m v
runShared (ResultShare tvar action) key param = liftIO $ do
(mvar, new) <- do
existing <- M.lookup key <$> readTVarIO tvar
case existing of
Just v -> return (v, False)
@ -89,9 +82,8 @@ runShared (ResultShare tvar fork action) key param = do
case M.lookup key m of
Just v' -> ((v', False), m)
Nothing -> ((v , True) , M.insert key v m)
when new $ fork $ do
when new $ void $ forkIO $ do
result <- action key param
liftIO $ do
atomically $ modifyTVar' tvar $ M.delete key
putMVar mvar result
liftIO $ readMVar mvar
atomically $ modifyTVar' tvar $ M.delete key
putMVar mvar result
readMVar mvar