diff options
| -rw-r--r-- | Annex/Content.hs | 2 | ||||
| -rw-r--r-- | Messages.hs | 14 | ||||
| -rw-r--r-- | Messages/Progress.hs | 39 | ||||
| -rw-r--r-- | Remote/BitTorrent.hs | 6 | ||||
| -rw-r--r-- | Remote/Bup.hs | 16 | ||||
| -rw-r--r-- | Remote/Helper/Ssh.hs | 4 | ||||
| -rw-r--r-- | Remote/Hook.hs | 3 | ||||
| -rw-r--r-- | Remote/Rsync.hs | 4 | ||||
| -rw-r--r-- | Utility/Metered.hs | 68 | ||||
| -rw-r--r-- | Utility/Process.hs | 16 | ||||
| -rw-r--r-- | Utility/Rsync.hs | 4 |
11 files changed, 117 insertions, 59 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index 977e92d51..310c43daf 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -565,7 +565,7 @@ downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig anyM (\u -> a u file uo) urls go (Just basecmd) = anyM (downloadcmd basecmd) urls downloadcmd basecmd url = - progressCommand stderr "sh" [Param "-c", Param $ gencmd url basecmd] + progressCommand "sh" [Param "-c", Param $ gencmd url basecmd] <&&> liftIO (doesFileExist file) gencmd url = massReplace [ ("%file", shellEscape file) diff --git a/Messages.hs b/Messages.hs index 8cf4647cd..0e83a7243 100644 --- a/Messages.hs +++ b/Messages.hs @@ -31,6 +31,7 @@ module Messages ( setupConsole, enableDebugOutput, disableDebugOutput, + commandProgressDisabled, ) where import Text.JSON @@ -96,8 +97,8 @@ doSideAction' b a = do {- Make way for subsequent output of a command. -} showOutput :: Annex () -showOutput = handleMessage q $ - putStr "\n" +showOutput = unlessM commandProgressDisabled $ + handleMessage q $ putStr "\n" showLongNote :: String -> Annex () showLongNote s = handleMessage (JSON.note s) $ @@ -183,3 +184,12 @@ enableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel DEBUG disableDebugOutput :: IO () disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE + +{- Should commands that normally output progress messages have that + - output disabled? -} +commandProgressDisabled :: Annex Bool +commandProgressDisabled = withOutputType $ \t -> return $ case t of + QuietOutput -> True + ProgressOutput -> True + JSONOutput -> True + NormalOutput -> False diff --git a/Messages/Progress.hs b/Messages/Progress.hs index cb55a8c28..24efe0156 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -49,33 +49,26 @@ showProgressDots :: Annex () showProgressDots = handleMessage q $ flushed $ putStr "." -{- Runs a command, that normally outputs progress to the specified handle. +{- Runs a command, that may output progress to either stdout or + - stderr, as well as other messages. - - - In quiet mode, normal output is suppressed. stderr is fed through the - - mkStderrEmitter. If the progress is output to stderr, then stderr is - - dropped, unless the command fails in which case the last line of output - - to stderr will be shown. + - In quiet mode, the output is suppressed, except for error messages. -} -progressCommand :: Handle -> FilePath -> [CommandParam] -> Annex Bool -progressCommand progresshandle cmd params = undefined +progressCommand :: FilePath -> [CommandParam] -> Annex Bool +progressCommand cmd params = progressCommandEnv cmd params Nothing -mkProgressHandler :: MeterUpdate -> Annex ProgressHandler -mkProgressHandler meter = ProgressHandler - <$> commandProgressDisabled - <*> (stderrhandler <$> mkStderrEmitter) - <*> pure meter - where - stderrhandler emitter h = unlessM (hIsEOF h) $ do - void $ emitter =<< hGetLine h - stderrhandler emitter h +progressCommandEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> Annex Bool +progressCommandEnv cmd params environ = ifM commandProgressDisabled + ( do + oh <- mkOutputHandler + liftIO $ demeterCommandEnv oh cmd params environ + , liftIO $ boolSystemEnv cmd params environ + ) -{- Should commands that normally output progress messages have that - - output disabled? -} -commandProgressDisabled :: Annex Bool -commandProgressDisabled = withOutputType $ \t -> return $ case t of - QuietOutput -> True - ProgressOutput -> True - _ -> False +mkOutputHandler :: Annex OutputHandler +mkOutputHandler = OutputHandler + <$> commandProgressDisabled + <*> mkStderrEmitter {- Generates an IO action that can be used to emit stderr. - diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 27844c262..2770f30ae 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -289,15 +289,15 @@ ariaParams ps = do return (ps ++ opts) runAria :: [CommandParam] -> Annex Bool -runAria ps = liftIO . boolSystem "aria2c" =<< ariaParams ps +runAria ps = progressCommand "aria2c" =<< ariaParams ps -- Parse aria output to find "(n%)" and update the progress meter -- with it. ariaProgress :: Maybe Integer -> MeterUpdate -> [CommandParam] -> Annex Bool ariaProgress Nothing _ ps = runAria ps ariaProgress (Just sz) meter ps = do - h <- mkProgressHandler meter - liftIO . commandMeter (parseAriaProgress sz) h "aria2c" + oh <- mkOutputHandler + liftIO . commandMeter (parseAriaProgress sz) oh meter "aria2c" =<< ariaParams ps parseAriaProgress :: Integer -> ProgressParser diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 01501dc9e..42f17e921 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -121,18 +121,22 @@ bup command buprepo params = do showOutput -- make way for bup output liftIO $ boolSystem "bup" $ bupParams command buprepo params -bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam] -bupSplitParams r buprepo k src = do +bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> [CommandParam] +bupSplitParams r buprepo k src = let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r - showOutput -- make way for bup output - return $ bupParams "split" buprepo + in bupParams "split" buprepo (os ++ [Param "-q", Param "-n", Param (bupRef k)] ++ src) store :: Remote -> BupRepo -> Storer store r buprepo = byteStorer $ \k b p -> do - params <- bupSplitParams r buprepo k [] + let params = bupSplitParams r buprepo k [] + showOutput -- make way for bup output let cmd = proc "bup" (toCommand params) - liftIO $ withHandle StdinHandle createProcessSuccess cmd $ \h -> do + runner <- ifM commandProgressDisabled + ( return feedWithQuietOutput + , return (withHandle StdinHandle) + ) + liftIO $ runner createProcessSuccess cmd $ \h -> do meteredWrite p h b return True diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index cbb78ee81..546e28048 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -106,8 +106,8 @@ rsyncHelper m params = do a <- case m of Nothing -> return $ rsync params Just meter -> do - h <- mkProgressHandler meter - return $ rsyncProgress h params + oh <- mkOutputHandler + return $ rsyncProgress oh meter params ifM (liftIO a) ( return True , do diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 592564772..6df326295 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -17,6 +17,7 @@ import Config.Cost import Annex.UUID import Remote.Helper.Special import Utility.Env +import Messages.Progress import qualified Data.Map as M @@ -113,7 +114,7 @@ runHook hook action k f a = maybe (return False) run =<< lookupHook hook action where run command = do showOutput -- make way for hook output - ifM (liftIO $ boolSystemEnv "sh" [Param "-c", Param command] =<< hookEnv action k f) + ifM (progressCommandEnv "sh" [Param "-c", Param command] =<< liftIO (hookEnv action k f)) ( a , do warning $ hook ++ " hook exited nonzero!" diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 1e7b08892..a882e081d 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -287,8 +287,8 @@ rsyncRemote direction o m params = do case m of Nothing -> liftIO $ rsync ps Just meter -> do - h <- mkProgressHandler meter - liftIO $ rsyncProgress h ps + oh <- mkOutputHandler + liftIO $ rsyncProgress oh meter ps where ps = opts ++ [Params "--progress"] ++ params opts diff --git a/Utility/Metered.hs b/Utility/Metered.hs index baeea0f59..a4f0f88ee 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,4 +1,4 @@ -{- Metered IO +{- Metered IO and actions - - Copyright 2012-2105 Joey Hess <id@joeyh.name> - @@ -146,6 +146,11 @@ defaultChunkSize = 32 * k - chunkOverhead k = 1024 chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific +data OutputHandler = OutputHandler + { quietMode :: Bool + , stderrHandler :: String -> IO () + } + {- Parses the String looking for a command's progress output, and returns - Maybe the number of bytes done so far, and any any remainder of the - string that could be an incomplete progress output. That remainder @@ -155,23 +160,16 @@ 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 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 +commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser oh meterupdate cmd params = catchBoolIO $ + withOEHandles createProcessSuccess p $ \(outh, errh) -> do + ep <- async $ handlestderr errh + op <- async $ feedprogress zeroBytesProcessed [] outh + wait ep + wait op where p = proc cmd (toCommand params) @@ -180,7 +178,7 @@ commandMeter progressparser progress cmd params = if S.null b then return True else do - unless (quietMode progress) $ do + unless (quietMode oh) $ do S.hPut stdout b hFlush stdout let s = w82s (S.unpack b) @@ -189,5 +187,41 @@ commandMeter progressparser progress cmd params = Nothing -> feedprogress prev buf' h (Just bytes) -> do when (bytes /= prev) $ - (meterUpdate progress) bytes + meterupdate bytes feedprogress bytes buf' h + + handlestderr h = unlessM (hIsEOF h) $ do + stderrHandler oh =<< hGetLine h + handlestderr h + +{- 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 +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 -> + unless (quietMode oh) $ + putStrLn l + wait ep + wait op + return True + where + 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 diff --git a/Utility/Process.hs b/Utility/Process.hs index 0f494810c..cbbe8a811 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -28,6 +28,7 @@ module Utility.Process ( withIOHandles, withOEHandles, withQuietOutput, + feedWithQuietOutput, createProcess, startInteractiveProcess, stdinHandle, @@ -296,6 +297,21 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do } creator p' $ const $ return () +{- Stdout and stderr are discarded, while the process is fed stdin + - from the handle. -} +feedWithQuietOutput + :: CreateProcessRunner + -> CreateProcess + -> (Handle -> IO a) + -> IO a +feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do + let p' = p + { std_in = CreatePipe + , std_out = UseHandle nullh + , std_err = UseHandle nullh + } + creator p' $ a . stdinHandle + devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null" diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index ce8e9602a..4f4c4eb5d 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -97,8 +97,8 @@ rsyncUrlIsPath s - - The params must enable rsync's --progress mode for this to work. -} -rsyncProgress :: ProgressHandler -> [CommandParam] -> IO Bool -rsyncProgress h = commandMeter parseRsyncProgress h "rsync" . rsyncParamsFixup +rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool +rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before - the first progress output, and each thereafter). The first number |