1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{- git-annex progress output
-
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Messages.Progress where
import Common
import Messages
import Utility.Metered
import Types
import Types.Messages
import Types.Key
import qualified Messages.JSON as JSON
import Messages.Concurrent
import qualified System.Console.Regions as Regions
import qualified System.Console.Concurrent as Console
{- Shows a progress meter while performing a transfer of a key.
- The action is passed the meter and a callback to use to update the meter.
-
- 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.
--}
metered :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (Meter -> MeterUpdate -> Annex a) -> Annex a
metered othermeter key getsrcfile a = withMessageState $ \st ->
flip go st =<< getsz
where
go _ (MessageState { outputType = QuietOutput }) = nometer
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
showOutput
meter <- liftIO $ mkMeter msize $
displayMeterHandle stdout bandwidthMeter
m <- liftIO $ rateLimitMeterUpdate 0.2 meter $
updateMeter meter
r <- a meter (combinemeter m)
liftIO $ clearMeterHandle meter stdout
return r
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
withProgressRegion $ \r -> do
meter <- liftIO $ mkMeter msize $ \_ msize' old new ->
let s = bandwidthMeter msize' old new
in Regions.setConsoleRegion r ('\n' : s)
m <- liftIO $ rateLimitMeterUpdate 0.2 meter $
updateMeter meter
a meter (combinemeter m)
go msize (MessageState { outputType = JSONOutput jsonoptions })
| jsonProgress jsonoptions = do
buf <- withMessageState $ return . jsonBuffer
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)
| otherwise = nometer
nometer = do
dummymeter <- liftIO $ mkMeter Nothing $
\_ _ _ _ -> return ()
a dummymeter (combinemeter (const noop))
combinemeter m = case othermeter of
Nothing -> m
Just om -> combineMeterUpdate m om
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
{- Poll file size to display meter. -}
meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
meteredFile file combinemeterupdate key a =
metered combinemeterupdate key (return Nothing) $ \_ p ->
watchFileSize file p a
{- Progress dots. -}
showProgressDots :: Annex ()
showProgressDots = outputMessage JSON.none "."
{- Runs a command, that may output progress to either stdout or
- stderr, as well as other messages.
-
- In quiet mode, the output is suppressed, except for error messages.
-}
progressCommand :: FilePath -> [CommandParam] -> Annex Bool
progressCommand cmd params = progressCommandEnv cmd params Nothing
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
)
mkOutputHandler :: Annex OutputHandler
mkOutputHandler = OutputHandler
<$> commandProgressDisabled
<*> mkStderrEmitter
mkOutputHandlerQuiet :: Annex OutputHandler
mkOutputHandlerQuiet = OutputHandler
<$> pure True
<*> 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
- messing it up with interleaved stderr from a command.
-}
mkStderrEmitter :: Annex (String -> IO ())
mkStderrEmitter = withMessageState go
where
go s
| concurrentOutputEnabled s = return Console.errorConcurrent
| otherwise = return (hPutStrLn stderr)
|
