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