WIP on making --quiet silence progress, and infra for concurrent progress bars

5 files changed, 45 insertions, 15 deletions

diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index 3112db1bd..6323d3a00 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -142,7 +142,7 @@ pipeLazy params feeder reader = do
 	setup = liftIO . createProcess
 	cleanup p (_, _, _, pid) = liftIO $ forceSuccessProcess p pid
 	go p = do
-		let (to, from) = bothHandles p
+		let (to, from) = ioHandles p
 		liftIO $ void $ forkIO $ do
 			feeder to
 			hClose to
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index 7d6e71cdd..baeea0f59 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -18,6 +18,7 @@ import Foreign.Storable (Storable(sizeOf))
 import System.Posix.Types
 import Data.Int
 import Data.Bits.Utils
+import Control.Concurrent.Async
 
 {- An action that can be run repeatedly, updating it on the bytes processed.
  -
@@ -146,7 +147,7 @@ defaultChunkSize = 32 * k - chunkOverhead
 	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific
 
 {- Parses the String looking for a command's progress output, and returns
- - Maybe the number of bytes rsynced so far, and any any remainder of the
+ - Maybe the number of bytes done so far, and any any remainder of the
  - string that could be an incomplete progress output. That remainder
  - should be prepended to future output, and fed back in. This interface
  - allows the command's output to be read in any desired size chunk, or
@@ -154,12 +155,23 @@ defaultChunkSize = 32 * k - chunkOverhead
  -}
 type ProgressParser = String -> (Maybe BytesProcessed, String)
 
+data ProgressHandler = ProgressHandler
+	{ quietMode :: Bool -- don't forward output to stdout
+	, stderrHandler :: Handle -> IO () -- callback to handle stderr
+	, meterUpdate :: MeterUpdate -- the progress meter to update
+	}
+
 {- Runs a command and runs a ProgressParser on its output, in order
- - to update the meter. The command's output is also sent to stdout. -}
-commandMeter :: ProgressParser -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool
-commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $
-	withHandle StdoutHandle createProcessSuccess p $
-		feedprogress zeroBytesProcessed []
+ - to update a meter.
+ -}
+commandMeter :: ProgressParser -> ProgressHandler -> FilePath -> [CommandParam] -> IO Bool
+commandMeter progressparser progress cmd params = 
+	liftIO $ catchBoolIO $
+		withOEHandles createProcessSuccess p $ \(outh, errh) -> do
+			ep <- async $ (stderrHandler progress) errh
+			op <- async $ feedprogress zeroBytesProcessed [] outh
+			wait ep
+			wait op
   where
 	p = proc cmd (toCommand params)
 
@@ -168,13 +180,14 @@ commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $
 		if S.null b
 			then return True
 			else do
-				S.hPut stdout b
-				hFlush stdout
+				unless (quietMode progress) $ do
+					S.hPut stdout b
+					hFlush stdout
 				let s = w82s (S.unpack b)
 				let (mbytes, buf') = progressparser (buf++s)
 				case mbytes of
 					Nothing -> feedprogress prev buf' h
 					(Just bytes) -> do
 						when (bytes /= prev) $
-							meterupdate bytes
+							(meterUpdate progress) bytes
 						feedprogress bytes buf' h
diff --git a/Utility/Process.hs b/Utility/Process.hs
index ae09b5958..64363cf6b 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -26,6 +26,7 @@ module Utility.Process (
 	processTranscript',
 	withHandle,
 	withIOHandles,
+	withOEHandles,
 	withQuietOutput,
 	createProcess,
 	startInteractiveProcess,
@@ -268,6 +269,20 @@ withIOHandles creator p a = creator p' $ a . ioHandles
 		, std_err = Inherit
 		}
 
+{- Like withHandle, but passes (stdout, stderr) handles to the action. -}
+withOEHandles
+	:: CreateProcessRunner
+	-> CreateProcess
+	-> ((Handle, Handle) -> IO a)
+	-> IO a
+withOEHandles creator p a = creator p' $ a . oeHandles
+  where
+	p' = p
+		{ std_in = Inherit
+		, std_out = CreatePipe
+		, std_err = CreatePipe
+		}
+
 {- Forces the CreateProcessRunner to run quietly;
  - both stdout and stderr are discarded. -}
 withQuietOutput
@@ -306,6 +321,8 @@ stderrHandle _ = error "expected stderrHandle"
 ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
 ioHandles (Just hin, Just hout, _, _) = (hin, hout)
 ioHandles _ = error "expected ioHandles"
+oeHandles (_, Just hout, Just herr, _) = (hout, herr)
+oeHandles _ = error "expected oeHandles"
 
 processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
 processHandle (_, _, _, pid) = pid
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 241202813..ce8e9602a 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -92,13 +92,13 @@ rsyncUrlIsPath s
 	| rsyncUrlIsShell s = False
 	| otherwise = ':' `notElem` s
 
-{- Runs rsync, but intercepts its progress output and updates a meter.
- - The progress output is also output to stdout. 
+{- Runs rsync, but intercepts its progress output and updates a progress
+ - meter.
  -
  - The params must enable rsync's --progress mode for this to work.
  -}
-rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool
-rsyncProgress meterupdate = commandMeter parseRsyncProgress meterupdate "rsync" . rsyncParamsFixup
+rsyncProgress :: ProgressHandler -> [CommandParam] -> IO Bool
+rsyncProgress h = commandMeter parseRsyncProgress h "rsync" . rsyncParamsFixup
 
 {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before
  - the first progress output, and each thereafter). The first number
diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs
index 52284d457..2a1dab51d 100644
--- a/Utility/SimpleProtocol.hs
+++ b/Utility/SimpleProtocol.hs
@@ -81,7 +81,7 @@ splitWord = separate isSpace
  - and duplicate stderr to stdout. Return two new handles
  - that are duplicates of the original (stdin, stdout). -}
 dupIoHandles :: IO (Handle, Handle)
-duoIoHandles = do
+dupIoHandles = do
 	readh <- hDuplicate stdin
 	writeh <- hDuplicate stdout
 	nullh <- openFile devNull ReadMode