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

Messages.hs

@@ -10,9 +10,6 @@ module Messages (
 	showStart',
 	showNote,
 	showAction,
-	showProgressDots,
-	metered,
-	meteredBytes,
 	showSideAction,
 	doSideAction,
 	doQuietSideAction,
@@ -33,28 +30,25 @@ module Messages (
 	showRaw,
 	setupConsole,
 	enableDebugOutput,
-	disableDebugOutput
+	disableDebugOutput,
 ) where
 
 import Text.JSON
-import Data.Progress.Meter
-import Data.Progress.Tracker
-import Data.Quantity
 import System.Log.Logger
 import System.Log.Formatter
 import System.Log.Handler (setFormatter)
 import System.Log.Handler.Simple
 
-import Common hiding (handle)
+import Common
 import Types
 import Types.Messages
+import Messages.Internal
 import qualified Messages.JSON as JSON
 import Types.Key
 import qualified Annex
-import Utility.Metered
 
 showStart :: String -> FilePath -> Annex ()
-showStart command file = handle (JSON.start command $ Just file) $
+showStart command file = handleMessage (JSON.start command $ Just file) $
 	flushed $ putStr $ command ++ " " ++ file ++ " "
 
 showStart' :: String -> Key -> Maybe FilePath -> Annex ()
@@ -62,42 +56,12 @@ showStart' command key afile = showStart command $
 	fromMaybe (key2file key) afile
 
 showNote :: String -> Annex ()
-showNote s = handle (JSON.note s) $
+showNote s = handleMessage (JSON.note s) $
 	flushed $ putStr $ "(" ++ s ++ ") "
 
 showAction :: String -> Annex ()
 showAction s = showNote $ s ++ "..."
 
-{- Progress dots. -}
-showProgressDots :: Annex ()
-showProgressDots = handle q $
-	flushed $ putStr "."
-
-{- 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 = go (keySize key)
-  where
-	go (Just size) = meteredBytes combinemeterupdate size a
-	go _ = a (const noop)
-
-{- Shows a progress meter while performing an action on a given number
- - of bytes. -}
-meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a
-meteredBytes combinemeterupdate size a = withOutputType go
-  where
-	go NormalOutput = do
-		progress <- liftIO $ newProgress "" size
-		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
-		showOutput
-		r <- a $ \n -> liftIO $ do
-			setP progress $ fromBytesProcessed n
-			displayMeter stdout meter
-			maybe noop (\m -> m n) combinemeterupdate
-		liftIO $ clearMeter stdout meter
-		return r
-	go _ = a (const noop)
-
 showSideAction :: String -> Annex ()
 showSideAction m = Annex.getState Annex.output >>= go
   where
@@ -108,7 +72,7 @@ showSideAction m = Annex.getState Annex.output >>= go
 			Annex.changeState $ \s -> s { Annex.output = st' }
 		| sideActionBlock st == InBlock = return ()
 		| otherwise = p
-	p = handle q $ putStrLn $ "(" ++ m ++ "...)"
+	p = handleMessage q $ putStrLn $ "(" ++ m ++ "...)"
 			
 showStoringStateAction :: Annex ()
 showStoringStateAction = showSideAction "recording state in git"
@@ -130,12 +94,13 @@ doSideAction' b a = do
   where
 	set o = Annex.changeState $ \s -> s {  Annex.output = o }
 
+{- Make way for subsequent output of a command. -}
 showOutput :: Annex ()
-showOutput = handle q $
+showOutput = handleMessage q $
 	putStr "\n"
 
 showLongNote :: String -> Annex ()
-showLongNote s = handle (JSON.note s) $
+showLongNote s = handleMessage (JSON.note s) $
 	putStrLn $ '\n' : indent s
 
 showEndOk :: Annex ()
@@ -145,7 +110,7 @@ showEndFail :: Annex ()
 showEndFail = showEndResult False
 
 showEndResult :: Bool -> Annex ()
-showEndResult ok = handle (JSON.end ok) $ putStrLn msg
+showEndResult ok = handleMessage (JSON.end ok) $ putStrLn msg
   where
 	msg
 		| ok = "ok"
@@ -159,7 +124,7 @@ warning = warning' . indent
 
 warning' :: String -> Annex ()
 warning' w = do
-	handle q $ putStr "\n"
+	handleMessage q $ putStr "\n"
 	liftIO $ do
 		hFlush stdout
 		hPutStrLn stderr w
@@ -175,7 +140,7 @@ indent = intercalate "\n" . map (\l -> "  " ++ l) . lines
 
 {- Shows a JSON fragment only when in json mode. -}
 maybeShowJSON :: JSON a => [(String, a)] -> Annex ()
-maybeShowJSON v = handle (JSON.add v) q
+maybeShowJSON v = handleMessage (JSON.add v) q
 
 {- Shows a complete JSON value, only when in json mode. -}
 showFullJSON :: JSON a => [(String, a)] -> Annex Bool
@@ -190,16 +155,16 @@ showFullJSON v = withOutputType $ liftIO . go
  - This is only needed when showStart and showEndOk is not used. -}
 showCustom :: String -> Annex Bool -> Annex ()
 showCustom command a = do
-	handle (JSON.start command Nothing) q
+	handleMessage (JSON.start command Nothing) q
 	r <- a
-	handle (JSON.end r) q
+	handleMessage (JSON.end r) q
 
 showHeader :: String -> Annex ()
-showHeader h = handle q $
+showHeader h = handleMessage q $
 	flushed $ putStr $ h ++ ": "
 
 showRaw :: String -> Annex ()
-showRaw s = handle q $ putStrLn s
+showRaw s = handleMessage q $ putStrLn s
 
 setupConsole :: IO ()
 setupConsole = do
@@ -218,19 +183,3 @@ enableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel DEBUG
 
 disableDebugOutput :: IO ()
 disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE
-
-handle :: IO () -> IO () -> Annex ()
-handle json normal = withOutputType go
-  where
-	go NormalOutput = liftIO normal
-	go QuietOutput = q
-	go JSONOutput = liftIO $ flushed json
-
-q :: Monad m => m ()
-q = noop
-
-flushed :: IO () -> IO ()
-flushed a = a >> hFlush stdout
-
-withOutputType :: (OutputType -> Annex a) -> Annex a
-withOutputType a = outputType <$> Annex.getState Annex.output >>= a

Messages/Internal.hs

@@ -0,0 +1,30 @@
+{- git-annex output messages
+ -
+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Messages.Internal where
+
+import Common
+import Types
+import Types.Messages
+import qualified Annex
+
+handleMessage :: IO () -> IO () -> Annex ()
+handleMessage json normal = withOutputType go
+  where
+	go NormalOutput = liftIO normal
+	go QuietOutput = q
+	go ProgressOutput = q
+	go JSONOutput = liftIO $ flushed json
+
+q :: Monad m => m ()
+q = noop
+
+flushed :: IO () -> IO ()
+flushed a = a >> hFlush stdout
+
+withOutputType :: (OutputType -> Annex a) -> Annex a
+withOutputType a = outputType <$> Annex.getState Annex.output >>= a

Messages/Progress.hs

@@ -0,0 +1,77 @@
+module Messages.Progress where
+
+import Common
+import Messages
+import Messages.Internal
+import Utility.Metered
+import Types
+import Types.Messages
+import Types.Key
+
+import Data.Progress.Meter
+import Data.Progress.Tracker
+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 = go (keySize key)
+  where
+	go (Just size) = meteredBytes combinemeterupdate size a
+	go _ = a (const noop)
+
+{- Shows a progress meter while performing an action on a given number
+ - of bytes. -}
+meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a
+meteredBytes combinemeterupdate size a = withOutputType go
+  where
+	go NormalOutput = do
+		progress <- liftIO $ newProgress "" size
+		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
+		showOutput
+		r <- a $ \n -> liftIO $ do
+			setP progress $ fromBytesProcessed n
+			displayMeter stdout meter
+			maybe noop (\m -> m n) combinemeterupdate
+		liftIO $ clearMeter stdout meter
+		return r
+	go _ = a (const noop)
+
+{- Progress dots. -}
+showProgressDots :: Annex ()
+showProgressDots = handleMessage q $
+	flushed $ putStr "."
+
+{- Runs a command, the output of which is some sort of progress display.
+ -
+ - Normally, this is displayed to the user.
+ -
+ - In QuietOutput mode, both the stdout and stderr are discarded,
+ - unless the command fails, in which case stderr will be displayed.
+ -}
+progressOutput :: FilePath -> [CommandParam] -> Annex Bool
+progressOutput cmd ps = undefined
+
+mkProgressHandler :: MeterUpdate -> Annex ProgressHandler
+mkProgressHandler meter = ProgressHandler
+	<$> quietmode
+	<*> (stderrhandler <$> mkStderrEmitter)
+	<*> pure meter
+  where
+	quietmode = withOutputType $ \t -> return $ case t of
+		ProgressOutput -> True
+		_ -> False
+	stderrhandler emitter h = do
+		void $ emitter =<< hGetLine stderr
+		stderrhandler emitter h
+
+{- Generates an IO action that can be used to emit stderr.
+ -
+ - When a progress meter is displayed, this takes care to avoid
+ - messing it up with interleaved stderr from a command.
+ -}
+mkStderrEmitter :: Annex (String -> IO ())
+mkStderrEmitter = withOutputType go
+  where
+	go ProgressOutput = return $ \s -> hPutStrLn stderr ("E: " ++ s)
+	go _ = return (hPutStrLn stderr)

Remote/BitTorrent.hs

@@ -19,6 +19,7 @@ import Logs.Web
 import Types.UrlContents
 import Types.CleanupActions
 import Types.Key
+import Messages.Progress
 import Utility.Metered
 import Utility.Tmp
 import Backend.URL
@@ -291,11 +292,12 @@ runAria :: [CommandParam] -> Annex Bool
 runAria ps = liftIO . boolSystem "aria2c" =<< ariaParams ps
 
 -- Parse aria output to find "(n%)" and update the progress meter
--- with it. The output is also output to stdout.
+-- with it.
 ariaProgress :: Maybe Integer -> MeterUpdate -> [CommandParam] -> Annex Bool
 ariaProgress Nothing _ ps = runAria ps
-ariaProgress (Just sz) meter ps =
-	liftIO . commandMeter (parseAriaProgress sz) meter "aria2c"
+ariaProgress (Just sz) meter ps = do
+	h <- mkProgressHandler meter
+	liftIO . commandMeter (parseAriaProgress sz) h "aria2c"
 		=<< ariaParams ps
 
 parseAriaProgress :: Integer -> ProgressParser

Remote/Helper/Ssh.hs

@@ -17,6 +17,7 @@ import CmdLine.GitAnnexShell.Fields (Field, fieldName)
 import qualified CmdLine.GitAnnexShell.Fields as Fields
 import Types.Key
 import Remote.Helper.Messages
+import Messages.Progress
 import Utility.Metered
 import Utility.Rsync
 import Types.Remote
@@ -100,9 +101,14 @@ dropKey r key = onRemote r (boolSystem, return False) "dropkey"
 	[]
 
 rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool
-rsyncHelper callback params = do
+rsyncHelper m params = do
 	showOutput -- make way for progress bar
-	ifM (liftIO $ (maybe rsync rsyncProgress callback) params)
+	a <- case m of
+		Nothing -> return $ rsync params
+		Just meter -> do
+			h <- mkProgressHandler meter
+			return $ rsyncProgress h params
+	ifM (liftIO a)
 		( return True
 		, do
 			showLongNote "rsync failed -- run git annex again to resume file transfer"

Remote/Rsync.hs

@@ -31,6 +31,7 @@ import Remote.Rsync.RsyncUrl
 import Crypto
 import Utility.Rsync
 import Utility.CopyFile
+import Messages.Progress
 import Utility.Metered
 import Utility.PID
 import Annex.Perms
@@ -281,11 +282,15 @@ showResumable a = ifM a
 	)
 
 rsyncRemote :: Direction -> RsyncOpts -> Maybe MeterUpdate -> [CommandParam] -> Annex Bool
-rsyncRemote direction o callback params = do
+rsyncRemote direction o m params = do
 	showOutput -- make way for progress bar
-	liftIO $ (maybe rsync rsyncProgress callback) $
-		opts ++ [Params "--progress"] ++ params
+	case m of
+		Nothing -> liftIO $ rsync ps
+		Just meter -> do
+			h <- mkProgressHandler meter
+			liftIO $ rsyncProgress h ps
   where
+	ps = opts ++ [Params "--progress"] ++ params
 	opts
 		| direction == Download = rsyncDownloadOptions o
 		| otherwise = rsyncUploadOptions o

Types/Messages.hs

@@ -7,7 +7,7 @@
 
 module Types.Messages where
 
-data OutputType = NormalOutput | QuietOutput | JSONOutput
+data OutputType = NormalOutput | QuietOutput | ProgressOutput | JSONOutput
 
 data SideActionBlock = NoBlock | StartBlock | InBlock
 	deriving (Eq)

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

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

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

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

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

debian/changelog

@@ -26,6 +26,9 @@ git-annex (5.20150328) UNRELEASED; urgency=medium
   * Significantly sped up processing of large numbers of directories
     passed to a single git-annex command.
   * version: Add --raw
+  * --quiet now suppresses progress displays from eg, rsync.
+    (The option already suppressed git-annex's own built-in progress
+    displays.)
 
  -- Joey Hess <id@joeyh.name>  Fri, 27 Mar 2015 16:04:43 -0400
 

doc/git-annex.mdwn

@@ -655,8 +655,7 @@ may not be explicitly listed on their individual man pages.
 
 * `--quiet`
 
-  Avoid the default verbose display of what is done; only show errors
-  and progress displays.
+  Avoid the default verbose display of what is done; only show errors.
 
 * `--verbose`