well along the way to fully quiet --quiet

Came up with a generic way to filter out progress messages while keeping
errors, for commands that use stderr for both.

--json mode will disable command outputs too.

11 files changed, 117 insertions, 59 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 977e92d51..310c43daf 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -565,7 +565,7 @@ downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
 			anyM (\u -> a u file uo) urls
 	go (Just basecmd) = anyM (downloadcmd basecmd) urls
 	downloadcmd basecmd url =
-		progressCommand stderr "sh" [Param "-c", Param $ gencmd url basecmd]
+		progressCommand "sh" [Param "-c", Param $ gencmd url basecmd]
 			<&&> liftIO (doesFileExist file)
 	gencmd url = massReplace
 		[ ("%file", shellEscape file)
diff --git a/Messages.hs b/Messages.hs
index 8cf4647cd..0e83a7243 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -31,6 +31,7 @@ module Messages (
 	setupConsole,
 	enableDebugOutput,
 	disableDebugOutput,
+	commandProgressDisabled,
 ) where
 
 import Text.JSON
@@ -96,8 +97,8 @@ doSideAction' b a = do
 
 {- Make way for subsequent output of a command. -}
 showOutput :: Annex ()
-showOutput = handleMessage q $
-	putStr "\n"
+showOutput = unlessM commandProgressDisabled $
+	handleMessage q $ putStr "\n"
 
 showLongNote :: String -> Annex ()
 showLongNote s = handleMessage (JSON.note s) $
@@ -183,3 +184,12 @@ enableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel DEBUG
 
 disableDebugOutput :: IO ()
 disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE
+
+{- Should commands that normally output progress messages have that
+ - output disabled? -}
+commandProgressDisabled :: Annex Bool
+commandProgressDisabled = withOutputType $ \t -> return $ case t of
+	QuietOutput -> True
+	ProgressOutput -> True
+	JSONOutput -> True
+	NormalOutput -> False
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index cb55a8c28..24efe0156 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -49,33 +49,26 @@ showProgressDots :: Annex ()
 showProgressDots = handleMessage q $
 	flushed $ putStr "."
 
-{- Runs a command, that normally outputs progress to the specified handle.
+{- Runs a command, that may output progress to either stdout or
+ - stderr, as well as other messages.
  -
- - In quiet mode, normal output is suppressed. stderr is fed through the
- - mkStderrEmitter. If the progress is output to stderr, then stderr is
- - dropped, unless the command fails in which case the last line of output
- - to stderr will be shown.
+ - In quiet mode, the output is suppressed, except for error messages.
  -}
-progressCommand :: Handle -> FilePath -> [CommandParam] -> Annex Bool
-progressCommand progresshandle cmd params = undefined
+progressCommand :: FilePath -> [CommandParam] -> Annex Bool
+progressCommand cmd params = progressCommandEnv cmd params Nothing
 
-mkProgressHandler :: MeterUpdate -> Annex ProgressHandler
-mkProgressHandler meter = ProgressHandler
-	<$> commandProgressDisabled
-	<*> (stderrhandler <$> mkStderrEmitter)
-	<*> pure meter
-  where
-	stderrhandler emitter h = unlessM (hIsEOF h) $ do
-		void $ emitter =<< hGetLine h
-		stderrhandler emitter h
+progressCommandEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> Annex Bool
+progressCommandEnv cmd params environ = ifM commandProgressDisabled
+	( do
+		oh <- mkOutputHandler
+		liftIO $ demeterCommandEnv oh cmd params environ
+	, liftIO $ boolSystemEnv cmd params environ
+	)
 
-{- Should commands that normally output progress messages have that
- - output disabled? -}
-commandProgressDisabled :: Annex Bool
-commandProgressDisabled = withOutputType $ \t -> return $ case t of
-	QuietOutput -> True
-	ProgressOutput -> True
-	_ -> False
+mkOutputHandler :: Annex OutputHandler
+mkOutputHandler = OutputHandler
+	<$> commandProgressDisabled
+	<*> mkStderrEmitter
 
 {- Generates an IO action that can be used to emit stderr.
  -
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index 27844c262..2770f30ae 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -289,15 +289,15 @@ ariaParams ps = do
 	return (ps ++ opts)
 
 runAria :: [CommandParam] -> Annex Bool
-runAria ps = liftIO . boolSystem "aria2c" =<< ariaParams ps
+runAria ps = progressCommand "aria2c" =<< ariaParams ps
 
 -- Parse aria output to find "(n%)" and update the progress meter
 -- with it.
 ariaProgress :: Maybe Integer -> MeterUpdate -> [CommandParam] -> Annex Bool
 ariaProgress Nothing _ ps = runAria ps
 ariaProgress (Just sz) meter ps = do
-	h <- mkProgressHandler meter
-	liftIO . commandMeter (parseAriaProgress sz) h "aria2c"
+	oh <- mkOutputHandler
+	liftIO . commandMeter (parseAriaProgress sz) oh meter "aria2c"
 		=<< ariaParams ps
 
 parseAriaProgress :: Integer -> ProgressParser
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 01501dc9e..42f17e921 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -121,18 +121,22 @@ bup command buprepo params = do
 	showOutput -- make way for bup output
 	liftIO $ boolSystem "bup" $ bupParams command buprepo params
 
-bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam]
-bupSplitParams r buprepo k src = do
+bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> [CommandParam]
+bupSplitParams r buprepo k src =
 	let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r
-	showOutput -- make way for bup output
-	return $ bupParams "split" buprepo 
+	in bupParams "split" buprepo 
 		(os ++ [Param "-q", Param "-n", Param (bupRef k)] ++ src)
 
 store :: Remote -> BupRepo -> Storer
 store r buprepo = byteStorer $ \k b p -> do
-	params <- bupSplitParams r buprepo k []
+	let params = bupSplitParams r buprepo k []
+	showOutput -- make way for bup output
 	let cmd = proc "bup" (toCommand params)
-	liftIO $ withHandle StdinHandle createProcessSuccess cmd $ \h -> do
+	runner <- ifM commandProgressDisabled
+		( return feedWithQuietOutput
+		, return (withHandle StdinHandle)
+		)
+	liftIO $ runner createProcessSuccess cmd $ \h -> do
 		meteredWrite p h b
 		return True
 
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index cbb78ee81..546e28048 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -106,8 +106,8 @@ rsyncHelper m params = do
 	a <- case m of
 		Nothing -> return $ rsync params
 		Just meter -> do
-			h <- mkProgressHandler meter
-			return $ rsyncProgress h params
+			oh <- mkOutputHandler
+			return $ rsyncProgress oh meter params
 	ifM (liftIO a)
 		( return True
 		, do
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 592564772..6df326295 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -17,6 +17,7 @@ import Config.Cost
 import Annex.UUID
 import Remote.Helper.Special
 import Utility.Env
+import Messages.Progress
 
 import qualified Data.Map as M
 
@@ -113,7 +114,7 @@ runHook hook action k f a = maybe (return False) run =<< lookupHook hook action
   where
 	run command = do
 		showOutput -- make way for hook output
-		ifM (liftIO $ boolSystemEnv "sh" [Param "-c", Param command] =<< hookEnv action k f)
+		ifM (progressCommandEnv "sh" [Param "-c", Param command] =<< liftIO (hookEnv action k f))
 			( a
 			, do
 				warning $ hook ++ " hook exited nonzero!"
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 1e7b08892..a882e081d 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -287,8 +287,8 @@ rsyncRemote direction o m params = do
 	case m of
 		Nothing -> liftIO $ rsync ps
 		Just meter -> do
-			h <- mkProgressHandler meter
-			liftIO $ rsyncProgress h ps
+			oh <- mkOutputHandler
+			liftIO $ rsyncProgress oh meter ps
   where
 	ps = opts ++ [Params "--progress"] ++ params
 	opts
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index baeea0f59..a4f0f88ee 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -1,4 +1,4 @@
-{- Metered IO
+{- Metered IO and actions
  -
  - Copyright 2012-2105 Joey Hess <id@joeyh.name>
  -
@@ -146,6 +146,11 @@ defaultChunkSize = 32 * k - chunkOverhead
 	k = 1024
 	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific
 
+data OutputHandler = OutputHandler
+	{ quietMode :: Bool
+	, stderrHandler :: String -> IO ()
+	}
+
 {- Parses the String looking for a command's progress output, and returns
  - Maybe the number of bytes done so far, and any any remainder of the
  - string that could be an incomplete progress output. That remainder
@@ -155,23 +160,16 @@ 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 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
+commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool
+commandMeter progressparser oh meterupdate cmd params = catchBoolIO $
+	withOEHandles createProcessSuccess p $ \(outh, errh) -> do
+		ep <- async $ handlestderr errh
+		op <- async $ feedprogress zeroBytesProcessed [] outh
+		wait ep
+		wait op
   where
 	p = proc cmd (toCommand params)
 
@@ -180,7 +178,7 @@ commandMeter progressparser progress cmd params =
 		if S.null b
 			then return True
 			else do
-				unless (quietMode progress) $ do
+				unless (quietMode oh) $ do
 					S.hPut stdout b
 					hFlush stdout
 				let s = w82s (S.unpack b)
@@ -189,5 +187,41 @@ commandMeter progressparser progress cmd params =
 					Nothing -> feedprogress prev buf' h
 					(Just bytes) -> do
 						when (bytes /= prev) $
-							(meterUpdate progress) bytes
+							meterupdate bytes
 						feedprogress bytes buf' h
+
+	handlestderr h = unlessM (hIsEOF h) $ do
+		stderrHandler oh =<< hGetLine h
+		handlestderr h
+
+{- Runs a command, that may display one or more progress meters on
+ - either stdout or stderr, and prevents the meters from being displayed.
+ -
+ - To suppress progress output, while displaying other messages,
+ - filter out lines that contain \r (typically used to reset to the
+ - beginning of the line when updating a progress display).
+ -
+ - The other command output is handled as configured by the OutputHandler.
+ -}
+demeterCommand :: OutputHandler -> FilePath -> [CommandParam] -> IO Bool
+demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing
+
+demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
+demeterCommandEnv oh cmd params environ = catchBoolIO $
+	withOEHandles createProcessSuccess p $ \(outh, errh) -> do
+		ep <- async $ avoidprogress errh $ stderrHandler oh
+		op <- async $ avoidprogress outh $ \l ->
+			unless (quietMode oh) $
+				putStrLn l
+		wait ep
+		wait op
+		return True
+  where
+	p = (proc cmd (toCommand params))
+		{ env = environ }
+
+	avoidprogress h emitter = unlessM (hIsEOF h) $ do
+		s <- hGetLine h
+		unless ('\r' `elem` s) $
+			emitter s
+		avoidprogress h emitter
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 0f494810c..cbbe8a811 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -28,6 +28,7 @@ module Utility.Process (
 	withIOHandles,
 	withOEHandles,
 	withQuietOutput,
+	feedWithQuietOutput,
 	createProcess,
 	startInteractiveProcess,
 	stdinHandle,
@@ -296,6 +297,21 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
 		}
 	creator p' $ const $ return ()
 
+{- Stdout and stderr are discarded, while the process is fed stdin
+ - from the handle. -}
+feedWithQuietOutput
+	:: CreateProcessRunner
+	-> CreateProcess
+	-> (Handle -> IO a)
+	-> IO a
+feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do
+	let p' = p
+		{ std_in = CreatePipe
+		, std_out = UseHandle nullh
+		, std_err = UseHandle nullh
+		}
+	creator p' $ a . stdinHandle
+
 devNull :: FilePath
 #ifndef mingw32_HOST_OS
 devNull = "/dev/null"
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index ce8e9602a..4f4c4eb5d 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -97,8 +97,8 @@ rsyncUrlIsPath s
  -
  - The params must enable rsync's --progress mode for this to work.
  -}
-rsyncProgress :: ProgressHandler -> [CommandParam] -> IO Bool
-rsyncProgress h = commandMeter parseRsyncProgress h "rsync" . rsyncParamsFixup
+rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool
+rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup
 
 {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before
  - the first progress output, and each thereafter). The first number