diff options
Diffstat (limited to 'Utility/Metered.hs')
| -rw-r--r-- | Utility/Metered.hs | 93 |
1 files changed, 77 insertions, 16 deletions
diff --git a/Utility/Metered.hs b/Utility/Metered.hs index e4f3b44..c34e931 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,6 +1,6 @@ -{- Metered IO +{- Metered IO and actions - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2105 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -17,6 +17,8 @@ import System.IO.Unsafe 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. - @@ -142,10 +144,15 @@ defaultChunkSize :: Int defaultChunkSize = 32 * k - chunkOverhead where k = 1024 - chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific + chunkOverhead = 2 * sizeOf (1 :: 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 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,21 +161,23 @@ defaultChunkSize = 32 * k - chunkOverhead type ProgressParser = String -> (Maybe BytesProcessed, String) {- 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 -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser oh meterupdate cmd params = + outputFilter cmd params Nothing + (feedprogress zeroBytesProcessed []) + handlestderr where - p = proc cmd (toCommand params) - feedprogress prev buf h = do - s <- hGetSomeString h 80 - if null s - then return True + b <- S.hGetSome h 80 + if S.null b + then return () else do - putStr s - hFlush stdout + unless (quietMode oh) $ 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 @@ -176,3 +185,55 @@ commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $ when (bytes /= prev) $ 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. + - + - 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 = outputFilter cmd params environ + (\outh -> avoidProgress True outh stdouthandler) + (\errh -> avoidProgress True errh $ stderrHandler oh) + where + stdouthandler l = + unless (quietMode oh) $ + putStrLn l + +{- 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 + +outputFilter + :: FilePath + -> [CommandParam] + -> Maybe [(String, String)] + -> (Handle -> IO ()) + -> (Handle -> IO ()) + -> IO Bool +outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do + (_, Just outh, Just errh, pid) <- createProcess p + { std_out = CreatePipe + , std_err = CreatePipe + } + void $ async $ tryIO (outfilter outh) >> hClose outh + void $ async $ tryIO (errfilter errh) >> hClose errh + ret <- checkSuccessProcess pid + return ret + where + p = (proc cmd (toCommand params)) + { env = environ } |