From d660e2443b99817a33127443e5d7314c99c291fc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 3 Apr 2015 16:48:30 -0400 Subject: WIP on making --quiet silence progress, and infra for concurrent progress bars --- Messages.hs | 83 +++++++++-------------------------------------- Messages/Internal.hs | 30 +++++++++++++++++ Messages/Progress.hs | 77 +++++++++++++++++++++++++++++++++++++++++++ Remote/BitTorrent.hs | 8 +++-- Remote/Helper/Ssh.hs | 10 ++++-- Remote/Rsync.hs | 11 +++++-- Types/Messages.hs | 2 +- Utility/Gpg.hs | 2 +- Utility/Metered.hs | 31 +++++++++++++----- Utility/Process.hs | 17 ++++++++++ Utility/Rsync.hs | 8 ++--- Utility/SimpleProtocol.hs | 2 +- debian/changelog | 3 ++ doc/git-annex.mdwn | 3 +- 14 files changed, 194 insertions(+), 93 deletions(-) create mode 100644 Messages/Internal.hs create mode 100644 Messages/Progress.hs diff --git a/Messages.hs b/Messages.hs index a8816218c..8cf4647cd 100644 --- a/Messages.hs +++ b/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 diff --git a/Messages/Internal.hs b/Messages/Internal.hs new file mode 100644 index 000000000..1dd856b5e --- /dev/null +++ b/Messages/Internal.hs @@ -0,0 +1,30 @@ +{- git-annex output messages + - + - Copyright 2010-2014 Joey Hess + - + - 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 diff --git a/Messages/Progress.hs b/Messages/Progress.hs new file mode 100644 index 000000000..60ab8271a --- /dev/null +++ b/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) diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index fe49d023a..27844c262 100644 --- a/Remote/BitTorrent.hs +++ b/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 diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 3addf2384..cbb78ee81 100644 --- a/Remote/Helper/Ssh.hs +++ b/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" diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index f39081299..1e7b08892 100644 --- a/Remote/Rsync.hs +++ b/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 diff --git a/Types/Messages.hs b/Types/Messages.hs index 224c2fe87..35bb19057 100644 --- a/Types/Messages.hs +++ b/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) diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 3112db1bd..6323d3a00 100644 --- a/Utility/Gpg.hs +++ b/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 diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 7d6e71cdd..baeea0f59 100644 --- a/Utility/Metered.hs +++ b/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 diff --git a/Utility/Process.hs b/Utility/Process.hs index ae09b5958..64363cf6b 100644 --- a/Utility/Process.hs +++ b/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 diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 241202813..ce8e9602a 100644 --- a/Utility/Rsync.hs +++ b/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 diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs index 52284d457..2a1dab51d 100644 --- a/Utility/SimpleProtocol.hs +++ b/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 diff --git a/debian/changelog b/debian/changelog index adddf91aa..092b0ff1a 100644 --- a/debian/changelog +++ b/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 Fri, 27 Mar 2015 16:04:43 -0400 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 34ba6fc82..27439cd3a 100644 --- a/doc/git-annex.mdwn +++ b/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` -- cgit v1.2.3