summaryrefslogtreecommitdiff
path: root/Messages/Progress.hs
blob: 25e2e03ae1b74e086f1e090ab2137c2490169349 (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
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
{- git-annex progress output
 -
 - Copyright 2010-2015 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Messages.Progress where

import Common
import Messages
import Messages.Internal
import Utility.Metered
import Types
import Types.Messages
import Types.Key

#ifdef WITH_ASCIIPROGRESS
import System.Console.AsciiProgress
import qualified System.Console.Terminal.Size as Terminal
import Control.Concurrent
#else
import Data.Progress.Meter
import Data.Progress.Tracker
import Data.Quantity
#endif

{- 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
#ifdef WITH_ASCIIPROGRESS
	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 ++ " " ++ endResult ok
			}
		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
#else
	-- Old progress bar code, not suitable for parallel output.
	go _ (ParallelOutput _) = do
		r <- nometer
		liftIO $ putStrLn $ fromMaybe (key2file key) af
		return r
	go size NormalOutput = do
		showOutput
		progress <- liftIO $ newProgress "" size
		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
		r <- a $ liftIO . pupdate meter progress
		liftIO $ clearMeter stdout meter
		return r
#endif

#ifdef WITH_ASCIIPROGRESS
	pupdate pg n = do
		let i = fromBytesProcessed n
		sofar <- stCompleted <$> getProgressStats pg
		when (i > sofar) $
			tickN pg (i - sofar)
		threadDelay 100
#else
	pupdate meter progress n = do
		setP progress $ fromBytesProcessed n
		displayMeter stdout meter
#endif
		maybe noop (\m -> m n) combinemeterupdate

	nometer = a (const noop)

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

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