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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
{- git-annex progress output
-
- Copyright 2010-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Messages.Progress where
import Common
import Messages
import Utility.Metered
import Types
import Types.Messages
import Types.Key
import Types.KeySource
import Utility.InodeCache
import qualified Messages.JSON as JSON
import Messages.Concurrent
import Messages.Internal
import qualified System.Console.Regions as Regions
import qualified System.Console.Concurrent as Console
import Control.Monad.IO.Class (MonadIO)
import Data.IORef
{- Class of things from which a size can be gotten to display a progress
- meter. -}
class MeterSize t where
getMeterSize :: t -> Annex (Maybe TotalSize)
instance MeterSize t => MeterSize (Maybe t) where
getMeterSize Nothing = pure Nothing
getMeterSize (Just t) = getMeterSize t
instance MeterSize FileSize where
getMeterSize = pure . Just . TotalSize
instance MeterSize Key where
getMeterSize = pure . fmap TotalSize . fromKey keySize
instance MeterSize InodeCache where
getMeterSize = pure . Just . TotalSize . inodeCacheFileSize
instance MeterSize KeySource where
getMeterSize = maybe (pure Nothing) getMeterSize . inodeCache
{- When the key's size is not known, the file is statted to get the size.
- This allows uploads of keys without size to still have progress
- displayed.
-}
data KeySizer = KeySizer Key (Annex (Maybe RawFilePath))
instance MeterSize KeySizer where
getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of
Just sz -> return (Just (TotalSize sz))
Nothing -> do
srcfile <- getsrcfile
case srcfile of
Nothing -> return Nothing
Just f -> catchMaybeIO $ liftIO $
TotalSize <$> getFileSize f
{- Shows a progress meter while performing an action.
- The action is passed the meter and a callback to use to update the meter.
--}
metered
:: MeterSize sizer
=> Maybe MeterUpdate
-> sizer
-> (Meter -> MeterUpdate -> Annex a)
-> Annex a
metered othermeter sizer a = withMessageState $ \st -> do
sz <- getMeterSize sizer
metered' st othermeter sz showOutput a
metered'
:: (Monad m, MonadIO m, MonadMask m)
=> MessageState
-> Maybe MeterUpdate
-> Maybe TotalSize
-> m ()
-- ^ this should run showOutput
-> (Meter -> MeterUpdate -> m a)
-> m a
metered' st othermeter msize showoutput a = go st
where
go (MessageState { outputType = QuietOutput }) = nometer
go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
showoutput
meter <- liftIO $ mkMeter msize $
displayMeterHandle stdout bandwidthMeter
m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $
updateMeter meter
r <- a meter (combinemeter m)
liftIO $ clearMeterHandle meter stdout
return r
go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
withProgressRegion st $ \r -> do
meter <- liftIO $ mkMeter msize $ \_ msize' old new ->
let s = bandwidthMeter msize' old new
in Regions.setConsoleRegion r ('\n' : s)
m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $
updateMeter meter
a meter (combinemeter m)
go (MessageState { outputType = JSONOutput jsonoptions })
| jsonProgress jsonoptions = do
let buf = jsonBuffer st
meter <- liftIO $ mkMeter msize $ \_ msize' _old new ->
JSON.progress buf msize' (meterBytesProcessed new)
m <- liftIO $ rateLimitMeterUpdate jsonratelimit meter $
updateMeter meter
a meter (combinemeter m)
| otherwise = nometer
go (MessageState { outputType = SerializedOutput h _ }) = do
liftIO $ outputSerialized h BeginProgressMeter
case msize of
Just sz -> liftIO $ outputSerialized h $ UpdateProgressMeterTotalSize sz
Nothing -> noop
szv <- liftIO $ newIORef msize
meter <- liftIO $ mkMeter msize $ \_ msize' _old new -> do
case msize' of
Just sz | msize' /= msize -> do
psz <- readIORef szv
when (msize' /= psz) $ do
writeIORef szv msize'
outputSerialized h $ UpdateProgressMeterTotalSize sz
_ -> noop
outputSerialized h $ UpdateProgressMeter $
meterBytesProcessed new
m <- liftIO $ rateLimitMeterUpdate minratelimit meter $
updateMeter meter
a meter (combinemeter m)
`finally` (liftIO $ outputSerialized h EndProgressMeter)
nometer = do
dummymeter <- liftIO $ mkMeter Nothing $
\_ _ _ _ -> return ()
a dummymeter (combinemeter (const noop))
combinemeter m = case othermeter of
Nothing -> m
Just om -> combineMeterUpdate m om
consoleratelimit = 0.2
jsonratelimit = 0.1
minratelimit = min consoleratelimit jsonratelimit
{- Poll file size to display meter. -}
meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
meteredFile file combinemeterupdate key a =
metered combinemeterupdate key $ \_ 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 (ProcessHandle -> Handle -> IO ())
mkStderrRelayer = do
quiet <- commandProgressDisabled
emitter <- mkStderrEmitter
return $ \ph h -> avoidProgress quiet ph 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)
|
