1{- git-annex progress output
2 -
3 - Copyright 2010-2020 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE OverloadedStrings #-}
10
11module Messages.Progress where
12
13import Common
14import qualified Annex
15import Messages
16import Utility.Metered
17import Types
18import Types.Messages
19import Types.Key
20import Types.KeySource
21import Utility.InodeCache
22import qualified Messages.JSON as JSON
23import Messages.Concurrent
24import Messages.Internal
25
26import qualified System.Console.Regions as Regions
27import qualified System.Console.Concurrent as Console
28import Control.Monad.IO.Class (MonadIO)
29import Data.IORef
30
31{- Class of things from which a size can be gotten to display a progress
32 - meter. -}
33class MeterSize t where
34	getMeterSize :: t -> Annex (Maybe TotalSize)
35
36instance MeterSize t => MeterSize (Maybe t) where
37	getMeterSize Nothing = pure Nothing
38	getMeterSize (Just t) = getMeterSize t
39
40instance MeterSize FileSize where
41	getMeterSize = pure . Just . TotalSize
42
43instance MeterSize Key where
44	getMeterSize = pure . fmap TotalSize . fromKey keySize
45
46instance MeterSize InodeCache where
47	getMeterSize = pure . Just . TotalSize . inodeCacheFileSize
48
49instance MeterSize KeySource where
50	getMeterSize = maybe (pure Nothing) getMeterSize . inodeCache
51
52{- When the key's size is not known, the file is statted to get the size.
53 - This allows uploads of keys without size to still have progress
54 - displayed.
55 -}
56data KeySizer = KeySizer Key (Annex (Maybe RawFilePath))
57
58instance MeterSize KeySizer where
59	getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of
60		Just sz -> return (Just (TotalSize sz))
61		Nothing -> do
62			srcfile <- getsrcfile
63			case srcfile of
64				Nothing -> return Nothing
65				Just f -> catchMaybeIO $ liftIO $
66					TotalSize <$> getFileSize f
67
68{- Shows a progress meter while performing an action.
69 - The action is passed the meter and a callback to use to update the meter.
70 -}
71metered
72	:: MeterSize sizer
73	=> Maybe MeterUpdate
74	-> sizer
75	-> (Meter -> MeterUpdate -> Annex a)
76	-> Annex a
77metered othermeter sizer a = withMessageState $ \st -> do
78	sz <- getMeterSize sizer
79	metered' st setclear othermeter sz showOutput a
80  where
81	setclear c = Annex.changeState $ \st -> st
82		{ Annex.output = (Annex.output st) { clearProgressMeter = c } }
83
84metered'
85	:: (Monad m, MonadIO m, MonadMask m)
86	=> MessageState
87	-> (IO () -> m ())
88	-- ^ This should set clearProgressMeter when progress meters
89	-- are being displayed; not needed when outputType is not
90	-- NormalOutput.
91	-> Maybe MeterUpdate
92	-> Maybe TotalSize
93	-> m ()
94	-- ^ this should run showOutput
95	-> (Meter -> MeterUpdate -> m a)
96	-> m a
97metered' st setclear othermeter msize showoutput a = go st
98  where
99	go (MessageState { outputType = QuietOutput }) = nometer
100	go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
101		showoutput
102		meter <- liftIO $ mkMeter msize $
103			displayMeterHandle stdout bandwidthMeter
104		let clear = clearMeterHandle meter stdout
105		setclear clear
106		m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $
107			updateMeter meter
108		r <- a meter (combinemeter m)
109		setclear noop
110		liftIO clear
111		return r
112	go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
113		withProgressRegion st $ \r -> do
114			meter <- liftIO $ mkMeter msize $ \_ msize' old new ->
115				let s = bandwidthMeter msize' old new
116				in Regions.setConsoleRegion r ('\n' : s)
117			m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $
118				updateMeter meter
119			a meter (combinemeter m)
120	go (MessageState { outputType = JSONOutput jsonoptions })
121		| jsonProgress jsonoptions = do
122			let buf = jsonBuffer st
123			meter <- liftIO $ mkMeter msize $ \_ msize' _old new ->
124				JSON.progress buf msize' (meterBytesProcessed new)
125			m <- liftIO $ rateLimitMeterUpdate jsonratelimit meter $
126				updateMeter meter
127			a meter (combinemeter m)
128		| otherwise = nometer
129	go (MessageState { outputType = SerializedOutput h _ }) = do
130		liftIO $ outputSerialized h BeginProgressMeter
131		case msize of
132			Just sz -> liftIO $ outputSerialized h $ UpdateProgressMeterTotalSize sz
133			Nothing -> noop
134		szv <- liftIO $ newIORef msize
135		meter <- liftIO $ mkMeter msize $ \_ msize' _old new -> do
136			case msize' of
137				Just sz | msize' /= msize -> do
138					psz <- readIORef szv
139					when (msize' /= psz) $ do
140						writeIORef szv msize'
141						outputSerialized h $ UpdateProgressMeterTotalSize sz
142				_ -> noop
143			outputSerialized h $ UpdateProgressMeter $
144				meterBytesProcessed new
145		m <- liftIO $ rateLimitMeterUpdate minratelimit meter $
146			updateMeter meter
147		a meter (combinemeter m)
148			`finally` (liftIO $ outputSerialized h EndProgressMeter)
149	nometer = do
150		dummymeter <- liftIO $ mkMeter Nothing $
151			\_ _ _ _ -> return ()
152		a dummymeter (combinemeter (const noop))
153
154	combinemeter m = case othermeter of
155		Nothing -> m
156		Just om -> combineMeterUpdate m om
157
158	consoleratelimit = 0.2
159
160	jsonratelimit = 0.1
161
162	minratelimit = min consoleratelimit jsonratelimit
163
164{- Poll file size to display meter. -}
165meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
166meteredFile file combinemeterupdate key a =
167	metered combinemeterupdate key $ \_ p ->
168		watchFileSize file p a
169
170{- Progress dots. -}
171showProgressDots :: Annex ()
172showProgressDots = outputMessage JSON.none "."
173
174{- Runs a command, that may output progress to either stdout or
175 - stderr, as well as other messages.
176 -
177 - In quiet mode, the output is suppressed, except for error messages.
178 -}
179progressCommand :: FilePath -> [CommandParam] -> Annex Bool
180progressCommand cmd params = progressCommandEnv cmd params Nothing
181
182progressCommandEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> Annex Bool
183progressCommandEnv cmd params environ = ifM commandProgressDisabled
184	( do
185		oh <- mkOutputHandler
186		liftIO $ demeterCommandEnv oh cmd params environ
187	, liftIO $ boolSystemEnv cmd params environ
188	)
189
190mkOutputHandler :: Annex OutputHandler
191mkOutputHandler = OutputHandler
192	<$> commandProgressDisabled
193	<*> mkStderrEmitter
194
195mkOutputHandlerQuiet :: Annex OutputHandler
196mkOutputHandlerQuiet = OutputHandler
197	<$> pure True
198	<*> mkStderrEmitter
199
200mkStderrRelayer :: Annex (ProcessHandle -> Handle -> IO ())
201mkStderrRelayer = do
202	quiet <- commandProgressDisabled
203	emitter <- mkStderrEmitter
204	return $ \ph h -> avoidProgress quiet ph h emitter
205
206{- Generates an IO action that can be used to emit stderr.
207 -
208 - When a progress meter is displayed, this takes care to avoid
209 - messing it up with interleaved stderr from a command.
210 -}
211mkStderrEmitter :: Annex (String -> IO ())
212mkStderrEmitter = withMessageState go
213  where
214	go s
215		| concurrentOutputEnabled s = return Console.errorConcurrent
216		| otherwise = return (hPutStrLn stderr)
217