relay external special remote stderr through progress suppression machinery (eep!)

It sounds worse than it is. ;)

Some external special remotes may run commands that display progress on
stderr. If git-annex is run with --quiet, this should filter out such
displays while letting the errors through.

Messages/Progress.hs

@@ -70,6 +70,12 @@ mkOutputHandler = OutputHandler
 	<$> commandProgressDisabled
 	<*> mkStderrEmitter
 
+mkStderrRelayer :: Annex (Handle -> IO ())
+mkStderrRelayer = do
+	quiet <- commandProgressDisabled
+	emitter <- mkStderrEmitter
+	return $ \h -> avoidProgress quiet h emitter
+
 {- Generates an IO action that can be used to emit stderr.
  -
  - When a progress meter is displayed, this takes care to avoid

Remote/External.hs

@@ -17,6 +17,7 @@ import qualified Git
 import Config
 import Remote.Helper.Special
 import Utility.Metered
+import Messages.Progress
 import Logs.Transfer
 import Logs.PreferredContent.Raw
 import Logs.RemoteState
@@ -26,6 +27,7 @@ import Annex.UUID
 import Creds
 
 import Control.Concurrent.STM
+import Control.Concurrent.Async
 import System.Log.Logger (debugM)
 import qualified Data.Map as M
 
@@ -323,19 +325,26 @@ fromExternal lck external extractor a =
 {- Starts an external remote process running, but does not handle checking
  - VERSION, etc. -}
 startExternal :: ExternalType -> Annex ExternalState
-startExternal externaltype = liftIO $ do
+startExternal externaltype = do
-	(Just hin, Just hout, _, pid) <- createProcess $ (proc cmd [])
+	errrelayer <- mkStderrRelayer
+	liftIO $ do
+		(Just hin, Just hout, Just herr, pid) <- createProcess $
+			(proc cmd [])
 				{ std_in = CreatePipe
 				, std_out = CreatePipe
-		, std_err = Inherit
+				, std_err = CreatePipe
 				}
 		fileEncoding hin
 		fileEncoding hout
+		fileEncoding herr
+		stderrelay <- async $ errrelayer herr
 		checkearlytermination =<< getProcessExitCode pid
 		return $ ExternalState
 			{ externalSend = hin
 			, externalReceive = hout
-		, externalPid = pid
+			, externalShutdown = do
+				cancel stderrelay
+				void $ waitForProcess pid
 			, externalPrepared = Unprepared
 			}
   where
@@ -357,7 +366,7 @@ stopExternal external = liftIO $ stop =<< atomically (tryReadTMVar v)
 		void $ atomically $ tryTakeTMVar v
 		hClose $ externalSend st
 		hClose $ externalReceive st
-		void $ waitForProcess $ externalPid st
+		externalShutdown st
 	v = externalState external
 
 externalRemoteProgram :: ExternalType -> String

Remote/External/Types.hs

@@ -70,7 +70,7 @@ type ExternalType = String
 data ExternalState = ExternalState
 	{ externalSend :: Handle
 	, externalReceive :: Handle
-	, externalPid :: ProcessHandle
+	, externalShutdown :: IO ()
 	, externalPrepared :: PrepareStatus
 	}
 

Utility/Metered.hs

@@ -197,10 +197,6 @@ commandMeter progressparser oh meterupdate cmd params = catchBoolIO $
 {- 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
@@ -209,8 +205,8 @@ 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
+		ep <- async $ avoidProgress True errh $ stderrHandler oh
-		op <- async $ avoidprogress outh $ \l ->
+		op <- async $ avoidProgress True outh $ \l ->
 			unless (quietMode oh) $
 				putStrLn l
 		wait ep
@@ -220,8 +216,13 @@ demeterCommandEnv oh cmd params environ = catchBoolIO $
 	p = (proc cmd (toCommand params))
 		{ env = environ }
 
-	avoidprogress h emitter = unlessM (hIsEOF h) $ do
+{- 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).
+ -}
+avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO ()
+avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do
 	s <- hGetLine h
-		unless ('\r' `elem` s) $
+	unless (doavoid && '\r' `elem` s) $
 		emitter s
-		avoidprogress h emitter
+	avoidProgress doavoid h emitter