summaryrefslogtreecommitdiff
path: root/Messages/Progress.hs
blob: 64aede514958184a8b3c8f40cabd9c2aaf4d5ed1 (plain)
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
{- 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 Messages.Internal
import Utility.Metered
import Types
import Types.Messages
import Types.Key

import System.Console.AsciiProgress
import qualified System.Console.Terminal.Size as Terminal
import Control.Concurrent

{- Shows a progress meter while performing a transfer of a key.
 - The action is passed a callback to use to update the meter. -}
metered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a
metered combinemeterupdate key af a = case keySize key of
	Nothing -> nometer
	Just size -> withOutputType (go $ fromInteger size)
  where
	go _ QuietOutput = nometer
	go _ JSONOutput = nometer
	go size _ = do
		showOutput
		liftIO $ putStrLn ""

		cols <- liftIO $ maybe 79 Terminal.width <$> Terminal.size
		let desc = truncatepretty cols $ fromMaybe (key2file key) af

		result <- liftIO newEmptyMVar
		pg <- liftIO $ newProgressBar def
			{ pgWidth = cols
			, pgFormat = desc ++ " :percent :bar ETA :eta"
			, pgTotal = size
			, pgOnCompletion = do
				ok <- takeMVar result
				putStrLn $ desc ++ " " ++
					if ok then "ok" else "failed"
			}
		r <- a $ liftIO . pupdate pg

		liftIO $ do
			-- See if the progress bar is complete or not.
			sofar <- stCompleted <$> getProgressStats pg
			putMVar result (sofar >= size)
			-- May not be actually complete if the action failed,
			-- but this just clears the progress bar.
			complete pg

		return r

	pupdate pg n = do
		let i = fromBytesProcessed n
		sofar <- stCompleted <$> getProgressStats pg
		when (i > sofar) $
			tickN pg (i - sofar)
		threadDelay 100
		maybe noop (\m -> m n) combinemeterupdate

	nometer = a (const noop)

	truncatepretty n s
		| length s > n = take (n-2) s ++ ".."
		| otherwise = s

{- Use when the progress meter is only desired for parallel
 - mode; as when a command's own progress output is preferred. -}
parallelMetered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a
parallelMetered combinemeterupdate key af a = withOutputType go
  where
	go (ParallelOutput _) = metered combinemeterupdate key af a
	go _ = a (fromMaybe (const noop) combinemeterupdate)

{- Progress dots. -}
showProgressDots :: Annex ()
showProgressDots = handleMessage q $
	flushed $ putStr "."

{- 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

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 = withOutputType go
  where
	go (ParallelOutput _) = return $ \s -> hPutStrLn stderr ("E: " ++ s)
	go _ = return (hPutStrLn stderr)