1{- Stall detection for transfers. 2 - 3 - Copyright 2020-2021 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8module Annex.StallDetection (detectStalls, StallDetection) where 9 10import Annex.Common 11import Types.StallDetection 12import Utility.Metered 13import Utility.HumanTime 14import Utility.DataUnits 15import Utility.ThreadScheduler 16 17import Control.Concurrent.STM 18import Control.Monad.IO.Class (MonadIO) 19 20{- This may be safely canceled (with eg uninterruptibleCancel), 21 - as long as the passed action can be safely canceled. -} 22detectStalls :: (Monad m, MonadIO m) => Maybe StallDetection -> TVar (Maybe BytesProcessed) -> m () -> m () 23detectStalls Nothing _ _ = noop 24detectStalls (Just StallDetectionDisabled) _ _ = noop 25detectStalls (Just (StallDetection minsz duration)) metervar onstall = 26 detectStalls' minsz duration metervar onstall Nothing 27detectStalls (Just ProbeStallDetection) metervar onstall = do 28 -- Only do stall detection once the progress is confirmed to be 29 -- consistently updating. After the first update, it needs to 30 -- advance twice within 30 seconds. With that established, 31 -- if no data at all is sent for a 60 second period, it's 32 -- assumed to be a stall. 33 v <- getval >>= waitforfirstupdate 34 ontimelyadvance v $ \v' -> ontimelyadvance v' $ 35 detectStalls' 1 duration metervar onstall 36 where 37 getval = liftIO $ atomically $ fmap fromBytesProcessed 38 <$> readTVar metervar 39 40 duration = Duration 60 41 42 delay = Seconds (fromIntegral (durationSeconds duration) `div` 2) 43 44 waitforfirstupdate startval = do 45 liftIO $ threadDelaySeconds delay 46 v <- getval 47 if v > startval 48 then return v 49 else waitforfirstupdate startval 50 51 ontimelyadvance v cont = do 52 liftIO $ threadDelaySeconds delay 53 v' <- getval 54 when (v' > v) $ 55 cont v' 56 57detectStalls' 58 :: (Monad m, MonadIO m) 59 => ByteSize 60 -> Duration 61 -> TVar (Maybe BytesProcessed) 62 -> m () 63 -> Maybe ByteSize 64 -> m () 65detectStalls' minsz duration metervar onstall st = do 66 liftIO $ threadDelaySeconds delay 67 -- Get whatever progress value was reported most recently, if any. 68 v <- liftIO $ atomically $ fmap fromBytesProcessed 69 <$> readTVar metervar 70 let cont = detectStalls' minsz duration metervar onstall v 71 case (st, v) of 72 (Nothing, _) -> cont 73 (_, Nothing) -> cont 74 (Just prev, Just sofar) 75 -- Just in case a progress meter somehow runs 76 -- backwards, or a second progress meter was 77 -- started and is at a smaller value than 78 -- the previous one. 79 | prev > sofar -> cont 80 | sofar - prev < minsz -> onstall 81 | otherwise -> cont 82 where 83 delay = Seconds (fromIntegral (durationSeconds duration)) 84