From 0d0f6d9c23a3398921b41d1f5b76bd061eaa6861 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 11 Dec 2020 18:26:30 -0400
Subject: [PATCH] fix stall detection to actually work when fully stalled

When fully stalled, the progress bar doesn't update, so waiting on a
MVar would block forever. There's no need to wait anyway, just wake up
after sleeping the configured period and check the current value.

Luckily Viasat makes it really easy for me to notice this kind of
mistake, by stalling long TCP connections frequently.
---
 Annex/TransferrerPool.hs | 29 ++++++++++++++---------------
 1 file changed, 14 insertions(+), 15 deletions(-)

diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs
index e9476c8826..86e3c036d0 100644
--- a/Annex/TransferrerPool.hs
+++ b/Annex/TransferrerPool.hs
@@ -142,7 +142,7 @@ performTransfer stalldetection level runannex r t info transferrer = do
 		liftIO $ sendRequest level t r
 			(associatedFile info)
 			(transferrerWrite transferrer)
-		metervar <- liftIO $ newEmptyTMVarIO
+		metervar <- liftIO $ newTVarIO Nothing
 		stalledvar <- liftIO $ newTVarIO False
 		tid <- liftIO $ async $ 
 			detectStalls stalldetection metervar $ do
@@ -166,32 +166,31 @@ performTransfer stalldetection level runannex r t info transferrer = do
 		runannex
 	
 	updatemeter bpv metervar (Just n) = liftIO $ do
-		atomically $ do
-			void $ tryTakeTMVar metervar
-			putTMVar metervar n
+		atomically $ writeTVar metervar (Just n)
 		atomically $ writeTVar bpv n
 	updatemeter _bpv metervar Nothing = liftIO $
-		atomically $ void $ tryTakeTMVar metervar
+		atomically $ writeTVar metervar Nothing
 
-detectStalls :: Maybe StallDetection -> TMVar BytesProcessed -> IO () -> IO ()
+detectStalls :: Maybe StallDetection -> TVar (Maybe BytesProcessed) -> IO () -> IO ()
 detectStalls Nothing _ _ = noop
 detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothing
   where
 	go st = do
 		starttm <- getPOSIXTime
 		threadDelaySeconds (Seconds (fromIntegral (durationSeconds duration)))
-		-- Get whatever progress value was reported most recently, or
-		-- if none were reported since last time, wait until one is
-		-- reported.
-		sofar <- atomically $ fromBytesProcessed <$> takeTMVar metervar
-		case st of
-			Nothing -> go (Just sofar)
-			Just prev
+		-- Get whatever progress value was reported last, if any.
+		v <- atomically $ fmap fromBytesProcessed
+			<$> readTVar metervar
+		let cont = go 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 -> go (Just sofar)
+				| prev > sofar -> cont
 				| otherwise -> do
 					endtm <- getPOSIXTime
 					let actualduration = endtm - starttm
@@ -200,7 +199,7 @@ detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothin
 						`div` max 1 (ceiling actualduration)
 					if sz < expectedsz
 						then onstall
-						else go (Just sofar)
+						else cont
 
 {- Starts a new git-annex transfer process, setting up handles
  - that will be used to communicate with it. -}