merge from git-annex

Fixes 2 bugs, one a data loss bug. It is possible to get those fixes
without merging all the other changes, if a backport is wanted.

1 files changed, 11 insertions, 9 deletions

diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index 1715f0b..a7c9c37 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -1,6 +1,6 @@
 {- Metered IO and actions
  -
- - Copyright 2012-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -118,23 +118,24 @@ withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
 withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->
 	hGetContentsMetered h meterupdate >>= a
 
-{- Writes a ByteString to a Handle, updating a meter as it's written. -}
-meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()
-meteredWrite meterupdate h = void . meteredWrite' meterupdate h
+{- Calls the action repeatedly with chunks from the lazy ByteString.
+ - Updates the meter after each chunk is processed. -}
+meteredWrite :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO ()
+meteredWrite meterupdate a = void . meteredWrite' meterupdate a
 
-meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed
-meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks 
+meteredWrite' :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO BytesProcessed
+meteredWrite' meterupdate a = go zeroBytesProcessed . L.toChunks 
   where
 	go sofar [] = return sofar
 	go sofar (c:cs) = do
-		S.hPut h c
+		a c
 		let !sofar' = addBytesProcessed sofar $ S.length c
 		meterupdate sofar'
 		go sofar' cs
 
 meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()
 meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->
-	meteredWrite meterupdate h b
+	meteredWrite meterupdate (S.hPut h) b
 
 {- Applies an offset to a MeterUpdate. This can be useful when
  - performing a sequence of actions, such as multiple meteredWriteFiles,
@@ -424,7 +425,8 @@ displayMeterHandle h rendermeter v msize old new = do
 		hPutStr h ('\r':s ++ padding)
 		hFlush h
 
--- | Clear meter displayed by displayMeterHandle.
+-- | Clear meter displayed by displayMeterHandle. May be called before
+-- outputting something else, followed by more calls to displayMeterHandle.
 clearMeterHandle :: Meter -> Handle -> IO ()
 clearMeterHandle (Meter _ _ v _) h = do
 	olds <- readMVar v