2015-04-04 00:08:25 +00:00
|
|
|
{- git-annex progress output
|
|
|
|
-
|
|
|
|
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2015-05-12 17:54:16 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
2015-04-03 20:48:30 +00:00
|
|
|
module Messages.Progress where
|
|
|
|
|
|
|
|
import Common
|
|
|
|
import Messages
|
|
|
|
import Utility.Metered
|
|
|
|
import Types
|
|
|
|
import Types.Messages
|
|
|
|
import Types.Key
|
2016-09-09 19:06:54 +00:00
|
|
|
import qualified Messages.JSON as JSON
|
2015-04-03 20:48:30 +00:00
|
|
|
|
2015-11-04 17:45:34 +00:00
|
|
|
#ifdef WITH_CONCURRENTOUTPUT
|
2015-11-06 17:44:57 +00:00
|
|
|
import Messages.Concurrent
|
|
|
|
import qualified System.Console.Regions as Regions
|
|
|
|
import qualified System.Console.Concurrent as Console
|
2015-11-04 17:45:34 +00:00
|
|
|
#endif
|
2015-11-06 17:44:57 +00:00
|
|
|
|
2015-04-03 20:48:30 +00:00
|
|
|
{- Shows a progress meter while performing a transfer of a key.
|
2018-03-13 01:46:58 +00:00
|
|
|
- The action is passed the meter and a callback to use to update the meter.
|
2017-11-14 20:27:39 +00:00
|
|
|
-
|
|
|
|
- When the key's size is not known, the srcfile is statted to get the size.
|
|
|
|
- This allows uploads of keys without size to still have progress
|
|
|
|
- displayed.
|
|
|
|
--}
|
2018-03-13 01:46:58 +00:00
|
|
|
metered :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (Meter -> MeterUpdate -> Annex a) -> Annex a
|
2017-11-14 20:27:39 +00:00
|
|
|
metered othermeter key getsrcfile a = withMessageState $ \st ->
|
|
|
|
flip go st =<< getsz
|
2015-04-03 20:48:30 +00:00
|
|
|
where
|
2016-09-09 16:57:42 +00:00
|
|
|
go _ (MessageState { outputType = QuietOutput }) = nometer
|
2017-11-14 20:27:39 +00:00
|
|
|
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
|
2015-05-12 17:54:16 +00:00
|
|
|
showOutput
|
2018-03-13 01:46:58 +00:00
|
|
|
meter <- liftIO $ mkMeter msize $
|
|
|
|
displayMeterHandle stdout bandwidthMeter
|
2018-03-13 22:32:18 +00:00
|
|
|
m <- liftIO $ rateLimitMeterUpdate 0.2 meter $
|
2017-05-16 03:32:17 +00:00
|
|
|
updateMeter meter
|
2018-03-13 01:46:58 +00:00
|
|
|
r <- a meter (combinemeter m)
|
2017-05-16 03:32:17 +00:00
|
|
|
liftIO $ clearMeterHandle meter stdout
|
2015-05-12 17:54:16 +00:00
|
|
|
return r
|
2017-11-14 20:27:39 +00:00
|
|
|
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
|
2016-02-15 19:27:58 +00:00
|
|
|
#if WITH_CONCURRENTOUTPUT
|
2016-09-09 16:57:42 +00:00
|
|
|
withProgressRegion $ \r -> do
|
2018-03-13 01:46:58 +00:00
|
|
|
meter <- liftIO $ mkMeter msize $ \_ msize' old new ->
|
|
|
|
let s = bandwidthMeter msize' old new
|
|
|
|
in Regions.setConsoleRegion r ('\n' : s)
|
2018-03-13 22:32:18 +00:00
|
|
|
m <- liftIO $ rateLimitMeterUpdate 0.2 meter $
|
2017-05-16 03:32:17 +00:00
|
|
|
updateMeter meter
|
2018-03-13 01:46:58 +00:00
|
|
|
a meter (combinemeter m)
|
2016-09-06 18:35:24 +00:00
|
|
|
#else
|
2016-09-09 16:57:42 +00:00
|
|
|
nometer
|
2015-05-12 17:54:16 +00:00
|
|
|
#endif
|
2018-02-19 18:03:23 +00:00
|
|
|
go msize (MessageState { outputType = JSONOutput jsonoptions })
|
|
|
|
| jsonProgress jsonoptions = do
|
|
|
|
buf <- withMessageState $ return . jsonBuffer
|
2018-03-13 01:46:58 +00:00
|
|
|
meter <- liftIO $ mkMeter msize $ \_ msize' _old (new, _now) ->
|
|
|
|
JSON.progress buf msize' new
|
|
|
|
m <- liftIO $ rateLimitMeterUpdate 0.1 meter $
|
|
|
|
updateMeter meter
|
|
|
|
a meter (combinemeter m)
|
2018-02-19 18:03:23 +00:00
|
|
|
| otherwise = nometer
|
2015-11-06 17:44:57 +00:00
|
|
|
|
2018-03-13 01:46:58 +00:00
|
|
|
nometer = do
|
|
|
|
dummymeter <- liftIO $ mkMeter Nothing $
|
|
|
|
\_ _ _ _ -> return ()
|
|
|
|
a dummymeter (combinemeter (const noop))
|
2015-04-03 20:48:30 +00:00
|
|
|
|
2016-09-08 17:17:43 +00:00
|
|
|
combinemeter m = case othermeter of
|
|
|
|
Nothing -> m
|
|
|
|
Just om -> combineMeterUpdate m om
|
2017-11-14 20:27:39 +00:00
|
|
|
|
|
|
|
getsz = case keySize key of
|
|
|
|
Just sz -> return (Just sz)
|
|
|
|
Nothing -> do
|
|
|
|
srcfile <- getsrcfile
|
|
|
|
case srcfile of
|
|
|
|
Nothing -> return Nothing
|
|
|
|
Just f -> catchMaybeIO $ liftIO $ getFileSize f
|
2016-09-08 17:17:43 +00:00
|
|
|
|
2018-04-07 03:09:19 +00:00
|
|
|
{- Poll file size to display meter. -}
|
2016-09-09 20:15:39 +00:00
|
|
|
meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
|
|
|
|
meteredFile file combinemeterupdate key a =
|
2018-04-07 03:09:19 +00:00
|
|
|
metered combinemeterupdate key (return Nothing) $ \_ p ->
|
|
|
|
watchFileSize file p a
|
2016-09-09 20:15:39 +00:00
|
|
|
|
2015-04-03 20:48:30 +00:00
|
|
|
{- Progress dots. -}
|
|
|
|
showProgressDots :: Annex ()
|
2016-09-09 19:49:44 +00:00
|
|
|
showProgressDots = outputMessage JSON.none "."
|
2015-04-03 20:48:30 +00:00
|
|
|
|
2015-04-04 18:34:03 +00:00
|
|
|
{- Runs a command, that may output progress to either stdout or
|
|
|
|
- stderr, as well as other messages.
|
2015-04-04 00:38:56 +00:00
|
|
|
-
|
2015-04-04 18:34:03 +00:00
|
|
|
- In quiet mode, the output is suppressed, except for error messages.
|
2015-04-04 00:38:56 +00:00
|
|
|
-}
|
2015-04-04 18:34:03 +00:00
|
|
|
progressCommand :: FilePath -> [CommandParam] -> Annex Bool
|
|
|
|
progressCommand cmd params = progressCommandEnv cmd params Nothing
|
2015-04-04 00:38:56 +00:00
|
|
|
|
2015-04-04 18:34:03 +00:00
|
|
|
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
|
|
|
|
)
|
2015-04-03 20:48:30 +00:00
|
|
|
|
2015-04-04 18:34:03 +00:00
|
|
|
mkOutputHandler :: Annex OutputHandler
|
|
|
|
mkOutputHandler = OutputHandler
|
|
|
|
<$> commandProgressDisabled
|
|
|
|
<*> mkStderrEmitter
|
2015-04-04 00:38:56 +00:00
|
|
|
|
2018-03-12 21:56:39 +00:00
|
|
|
mkOutputHandlerQuiet :: Annex OutputHandler
|
|
|
|
mkOutputHandlerQuiet = OutputHandler
|
|
|
|
<$> pure True
|
|
|
|
<*> mkStderrEmitter
|
|
|
|
|
2015-04-04 18:53:17 +00:00
|
|
|
mkStderrRelayer :: Annex (Handle -> IO ())
|
|
|
|
mkStderrRelayer = do
|
|
|
|
quiet <- commandProgressDisabled
|
|
|
|
emitter <- mkStderrEmitter
|
|
|
|
return $ \h -> avoidProgress quiet h emitter
|
|
|
|
|
2015-04-03 20:48:30 +00:00
|
|
|
{- 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 ())
|
2016-09-09 16:57:42 +00:00
|
|
|
mkStderrEmitter = withMessageState go
|
2015-04-03 20:48:30 +00:00
|
|
|
where
|
2015-11-04 17:45:34 +00:00
|
|
|
#ifdef WITH_CONCURRENTOUTPUT
|
2016-09-09 16:57:42 +00:00
|
|
|
go s | concurrentOutputEnabled s = return Console.errorConcurrent
|
2015-11-04 17:45:34 +00:00
|
|
|
#endif
|
2015-04-03 20:48:30 +00:00
|
|
|
go _ = return (hPutStrLn stderr)
|