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:
parent
c9c7da5902
commit
f37b9b3f52
12 changed files with 285 additions and 109 deletions
src/Control/Concurrent
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue