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.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Logger
import Control.Monad.Random (MonadRandom(..), evalRand)
@ -164,7 +165,9 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
MatchAt nextTime -> do
JobContext{jobCrontab} <- ask
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
where
acc :: NominalDiffTime
@ -190,14 +193,17 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
where
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
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
| diffT < acc -> return True
| otherwise -> do
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
awaitDelayThread = False <$ takeTMVar retVar
awaitCrontabChange = do