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