Rate limit console progress display updates to 10 per second. Was updating as frequently as changes were reported, up to hundreds of times per second, which used unncessary bandwidth when running git-annex over ssh etc.

3 files changed, 42 insertions, 6 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 552cf3888..0c71e4638 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,12 @@
+git-annex (6.20160908) UNRELEASED; urgency=medium
+
+  * Rate limit console progress display updates to 10 per second.
+    Was updating as frequently as changes were reported, up to hundreds of
+    times per second, which used unncessary bandwidth when running git-annex
+    over ssh etc.
+
+ -- Joey Hess <id@joeyh.name>  Thu, 08 Sep 2016 12:48:55 -0400
+
 git-annex (6.20160907) unstable; urgency=medium
 
   * Windows: Handle shebang in external special remote program.
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index c0a88be94..2cef9a759 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -30,7 +30,7 @@ import Data.Quantity
 {- Shows a progress meter while performing a transfer of a key.
  - The action is passed a callback to use to update the meter. -}
 metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
-metered combinemeterupdate key a = case keySize key of
+metered othermeter key a = case keySize key of
 	Nothing -> nometer
 	Just size -> withOutputType (go $ fromInteger size)
   where
@@ -39,21 +39,21 @@ metered combinemeterupdate key a = case keySize key of
 	go size NormalOutput = do
 		showOutput
 		(progress, meter) <- mkmeter size
-		r <- a $ \n -> liftIO $ do
+		m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do
 			setP progress $ fromBytesProcessed n
 			displayMeter stdout meter
-			maybe noop (\m -> m n) combinemeterupdate
+		r <- a (combinemeter m)
 		liftIO $ clearMeter stdout meter
 		return r
 #if WITH_CONCURRENTOUTPUT
 	go size o@(ConcurrentOutput {})
 		| concurrentOutputEnabled o = withProgressRegion $ \r -> do
 			(progress, meter) <- mkmeter size
-			a $ \n -> liftIO $ do
+			m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do
 				setP progress $ fromBytesProcessed n
 				s <- renderMeter meter
 				Regions.setConsoleRegion r ("\n" ++ s)
-				maybe noop (\m -> m n) combinemeterupdate
+			a (combinemeter m)
 #else
 	go _size _o
 #endif
@@ -66,6 +66,10 @@ metered combinemeterupdate key a = case keySize key of
 
 	nometer = a (const noop)
 
+	combinemeter m = case othermeter of
+		Nothing -> m
+		Just om -> combineMeterUpdate m om
+
 {- Use when the progress meter is only desired for concurrent
  - output; as when a command's own progress output is preferred. -}
 concurrentMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index da83fd8cd..440aa3f07 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -1,6 +1,6 @@
 {- Metered IO and actions
  -
- - Copyright 2012-2105 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2106 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -21,6 +21,8 @@ import Data.Bits.Utils
 import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Monad.IO.Class (MonadIO)
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
 
 {- An action that can be run repeatedly, updating it on the bytes processed.
  -
@@ -259,3 +261,24 @@ outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do
   where
 	p = (proc cmd (toCommand params))
 		{ env = environ }
+
+-- | Limit a meter to only update once per unit of time.
+--
+-- It's nice to display the final update to 100%, even if it comes soon
+-- after a previous update. To make that happen, a total size has to be
+-- provided.
+rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate
+rateLimitMeterUpdate delta totalsize meterupdate = do
+	lastupdate <- newMVar (toEnum 0 :: POSIXTime)
+	return $ mu lastupdate
+  where
+	mu lastupdate n@(BytesProcessed i) = case totalsize of
+		Just t | i >= t -> meterupdate n
+		_ -> do
+			now <- getPOSIXTime
+			prev <- takeMVar lastupdate
+			if now - prev >= delta
+				then do
+					putMVar lastupdate now
+					meterupdate n
+				else putMVar lastupdate prev