git-annex/Messages/Progress.hs

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