2021-02-03 17:19:47 +00:00
|
|
|
{- Stall detection for transfers.
|
|
|
|
-
|
|
|
|
- Copyright 2020-2021 Joey Hess <id@joeyh.name>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
|
|
|
module Annex.StallDetection (detectStalls, StallDetection) where
|
|
|
|
|
|
|
|
import Annex.Common
|
|
|
|
import Types.StallDetection
|
|
|
|
import Utility.Metered
|
|
|
|
import Utility.HumanTime
|
|
|
|
import Utility.DataUnits
|
|
|
|
import Utility.ThreadScheduler
|
|
|
|
|
|
|
|
import Control.Concurrent.STM
|
2021-02-03 19:35:32 +00:00
|
|
|
import Control.Monad.IO.Class (MonadIO)
|
2021-02-03 17:19:47 +00:00
|
|
|
|
2021-02-03 19:35:32 +00:00
|
|
|
{- This may be safely canceled (with eg uninterruptibleCancel),
|
|
|
|
- as long as the passed action can be safely canceled. -}
|
|
|
|
detectStalls :: (Monad m, MonadIO m) => Maybe StallDetection -> TVar (Maybe BytesProcessed) -> m () -> m ()
|
2021-02-03 17:19:47 +00:00
|
|
|
detectStalls Nothing _ _ = noop
|
2021-02-03 19:35:32 +00:00
|
|
|
detectStalls (Just StallDetectionDisabled) _ _ = noop
|
2021-02-03 17:19:47 +00:00
|
|
|
detectStalls (Just (StallDetection minsz duration)) metervar onstall =
|
|
|
|
detectStalls' minsz duration metervar onstall Nothing
|
|
|
|
detectStalls (Just ProbeStallDetection) metervar onstall = do
|
|
|
|
-- Only do stall detection once the progress is confirmed to be
|
|
|
|
-- consistently updating. After the first update, it needs to
|
|
|
|
-- advance twice within 30 seconds. With that established,
|
|
|
|
-- if no data at all is sent for a 60 second period, it's
|
|
|
|
-- assumed to be a stall.
|
|
|
|
v <- getval >>= waitforfirstupdate
|
|
|
|
ontimelyadvance v $ \v' -> ontimelyadvance v' $
|
|
|
|
detectStalls' 1 duration metervar onstall
|
|
|
|
where
|
2021-02-03 19:35:32 +00:00
|
|
|
getval = liftIO $ atomically $ fmap fromBytesProcessed
|
2021-02-03 17:19:47 +00:00
|
|
|
<$> readTVar metervar
|
|
|
|
|
|
|
|
duration = Duration 60
|
|
|
|
|
|
|
|
delay = Seconds (fromIntegral (durationSeconds duration) `div` 2)
|
|
|
|
|
|
|
|
waitforfirstupdate startval = do
|
2021-02-03 19:35:32 +00:00
|
|
|
liftIO $ threadDelaySeconds delay
|
2021-02-03 17:19:47 +00:00
|
|
|
v <- getval
|
|
|
|
if v > startval
|
|
|
|
then return v
|
|
|
|
else waitforfirstupdate startval
|
|
|
|
|
|
|
|
ontimelyadvance v cont = do
|
2021-02-03 19:35:32 +00:00
|
|
|
liftIO $ threadDelaySeconds delay
|
2021-02-03 17:19:47 +00:00
|
|
|
v' <- getval
|
|
|
|
when (v' > v) $
|
|
|
|
cont v'
|
|
|
|
|
|
|
|
detectStalls'
|
2021-02-03 19:35:32 +00:00
|
|
|
:: (Monad m, MonadIO m)
|
|
|
|
=> ByteSize
|
2021-02-03 17:19:47 +00:00
|
|
|
-> Duration
|
|
|
|
-> TVar (Maybe BytesProcessed)
|
2021-02-03 19:35:32 +00:00
|
|
|
-> m ()
|
2021-02-03 17:19:47 +00:00
|
|
|
-> Maybe ByteSize
|
2021-02-03 19:35:32 +00:00
|
|
|
-> m ()
|
2021-02-03 17:19:47 +00:00
|
|
|
detectStalls' minsz duration metervar onstall st = do
|
2021-02-03 19:35:32 +00:00
|
|
|
liftIO $ threadDelaySeconds delay
|
2021-02-03 17:19:47 +00:00
|
|
|
-- Get whatever progress value was reported most recently, if any.
|
2021-02-03 19:35:32 +00:00
|
|
|
v <- liftIO $ atomically $ fmap fromBytesProcessed
|
2021-02-03 17:19:47 +00:00
|
|
|
<$> readTVar metervar
|
|
|
|
let cont = detectStalls' minsz duration metervar onstall v
|
|
|
|
case (st, v) of
|
|
|
|
(Nothing, _) -> cont
|
|
|
|
(_, Nothing) -> cont
|
|
|
|
(Just prev, Just sofar)
|
|
|
|
-- Just in case a progress meter somehow runs
|
|
|
|
-- backwards, or a second progress meter was
|
|
|
|
-- started and is at a smaller value than
|
|
|
|
-- the previous one.
|
|
|
|
| prev > sofar -> cont
|
|
|
|
| sofar - prev < minsz -> onstall
|
|
|
|
| otherwise -> cont
|
|
|
|
where
|
|
|
|
delay = Seconds (fromIntegral (durationSeconds duration))
|