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.

diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs
index e9476c8826b895c5458e34ae259a890d3231b6c3..86e3c036d0990920ede37fdb894f3b673707e90a 100644 (file)
--- 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. -}