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.

4 files changed, 44 insertions, 28 deletions

diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index 24efe0156..e3df73ea4 100644
--- a/Messages/Progress.hs
+++ b/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
diff --git a/Remote/External.hs b/Remote/External.hs
index 39531998d..adfd79113 100644
--- a/Remote/External.hs
+++ b/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,21 +325,28 @@ 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
-	(Just hin, Just hout, _, pid) <- createProcess $ (proc cmd [])
-		{ std_in = CreatePipe
-		, std_out = CreatePipe
-		, std_err = Inherit
-		}
-	fileEncoding hin
-	fileEncoding hout
-	checkearlytermination =<< getProcessExitCode pid
-	return $ ExternalState
-		{ externalSend = hin
-		, externalReceive = hout
-		, externalPid = pid
-		, externalPrepared = Unprepared
-		}
+startExternal externaltype = do
+	errrelayer <- mkStderrRelayer
+	liftIO $ do
+		(Just hin, Just hout, Just herr, pid) <- createProcess $
+			(proc cmd [])
+				{ std_in = CreatePipe
+				, std_out = CreatePipe
+				, std_err = CreatePipe
+				}
+		fileEncoding hin
+		fileEncoding hout
+		fileEncoding herr
+		stderrelay <- async $ errrelayer herr
+		checkearlytermination =<< getProcessExitCode pid
+		return $ ExternalState
+			{ externalSend = hin
+			, externalReceive = hout
+			, externalShutdown = do
+				cancel stderrelay
+				void $ waitForProcess pid
+			, externalPrepared = Unprepared
+			}
   where
 	cmd = externalRemoteProgram externaltype
 
@@ -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
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index c7a28a359..3c9e89d40 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -70,7 +70,7 @@ type ExternalType = String
 data ExternalState = ExternalState
 	{ externalSend :: Handle
 	, externalReceive :: Handle
-	, externalPid :: ProcessHandle
+	, externalShutdown :: IO ()
 	, externalPrepared :: PrepareStatus
 	}
 
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index a4f0f88ee..54f038f81 100644
--- a/Utility/Metered.hs
+++ b/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
-		op <- async $ avoidprogress outh $ \l ->
+		ep <- async $ avoidProgress True errh $ stderrHandler oh
+		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
-		s <- hGetLine h
-		unless ('\r' `elem` s) $
-			emitter s
-		avoidprogress h emitter
+{- 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 (doavoid && '\r' `elem` s) $
+		emitter s
+	avoidProgress doavoid h emitter