fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix busy waiting

Browse Source
This commit is contained in:
Gregor Kleen 2018-10-13 22:01:03 +02:00
parent ff68ef7c9f
commit d6e0e9f7ca
1 changed files with 9 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/Jobs.hs
View File

@ -68,6 +68,7 @@ import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate) import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)
import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Logger
import Control.Monad.Random (MonadRandom(..), evalRand) import Control.Monad.Random (MonadRandom(..), evalRand)
@ -164,7 +165,9 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
MatchAt nextTime -> do MatchAt nextTime -> do
JobContext{jobCrontab} <- ask JobContext{jobCrontab} <- ask
nextTime' <- applyJitter jobCtl nextTime nextTime' <- applyJitter jobCtl nextTime
whenM (liftIO $ waitUntil jobCrontab currentCrontab nextTime') $logDebugS "Cron" [st|Waiting until #{tshow nextTime'} to execute #{tshow jobCtl}|]
logFunc <- askLoggerIO
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
doJob doJob
where where
acc :: NominalDiffTime acc :: NominalDiffTime
@ -190,14 +193,17 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
where where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron
waitUntil :: (Eq a, MonadResourceBase m) => TVar a -> a -> UTCTime -> m Bool waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do waitUntil crontabTV crontab nextTime = runResourceT $ do
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
let waitTime = fromInteger (floor $ diffT / acc) * toRational acc
waitTime' = realToFrac waitTime :: NominalDiffTime
$logDebugS "waitUntil" [st|#{tshow diffT} (#{tshow waitTime'})|]
if if
| diffT < acc -> return True | diffT < acc -> return True
| otherwise -> do | otherwise -> do
retVar <- liftIO newEmptyTMVarIO retVar <- liftIO newEmptyTMVarIO
void $ allocate (liftIO $ forkFinally (threadDelay . floor $ toRational acc * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread) void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread)
let let
awaitDelayThread = False <$ takeTMVar retVar awaitDelayThread = False <$ takeTMVar retVar
awaitCrontabChange = do awaitCrontabChange = do