From 8815f95d1ad0413ca35e6873f4b7b272bac629db Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 4 Apr 2015 14:53:17 -0400 Subject: 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 | 6 ++++++ Remote/External.hs | 41 +++++++++++++++++++++++++---------------- Remote/External/Types.hs | 2 +- Utility/Metered.hs | 23 ++++++++++++----------- 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 -- cgit v1.2.3