diff options
-rw-r--r-- | Messages.hs | 2 | ||||
-rw-r--r-- | Messages/Internal.hs | 2 | ||||
-rw-r--r-- | Messages/Progress.hs | 10 | ||||
-rw-r--r-- | Remote/Git.hs | 15 | ||||
-rw-r--r-- | Types/Messages.hs | 2 |
5 files changed, 22 insertions, 9 deletions
diff --git a/Messages.hs b/Messages.hs index 0e83a7243..d8be718cc 100644 --- a/Messages.hs +++ b/Messages.hs @@ -190,6 +190,6 @@ disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE commandProgressDisabled :: Annex Bool commandProgressDisabled = withOutputType $ \t -> return $ case t of QuietOutput -> True - ProgressOutput -> True + ParallelOutput _ -> True JSONOutput -> True NormalOutput -> False diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 1dd856b5e..2495f4fd3 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -17,7 +17,7 @@ handleMessage json normal = withOutputType go where go NormalOutput = liftIO normal go QuietOutput = q - go ProgressOutput = q + go (ParallelOutput _) = q go JSONOutput = liftIO $ flushed json q :: Monad m => m () diff --git a/Messages/Progress.hs b/Messages/Progress.hs index c563ffa6f..70ed96c5a 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -26,6 +26,14 @@ metered combinemeterupdate key a = go (keySize key) go (Just size) = meteredBytes combinemeterupdate size a go _ = a (const noop) +{- 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 -> (MeterUpdate -> Annex a) -> Annex a +parallelMetered combinemeterupdate key a = withOutputType go + where + go (ParallelOutput _) = metered combinemeterupdate key a + go _ = a (fromMaybe (const noop) combinemeterupdate) + {- Shows a progress meter while performing an action on a given number - of bytes. -} meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a @@ -99,5 +107,5 @@ mkStderrRelayer = do mkStderrEmitter :: Annex (String -> IO ()) mkStderrEmitter = withOutputType go where - go ProgressOutput = return $ \s -> hPutStrLn stderr ("E: " ++ s) + go (ParallelOutput _) = return $ \s -> hPutStrLn stderr ("E: " ++ s) go _ = return (hPutStrLn stderr) diff --git a/Remote/Git.hs b/Remote/Git.hs index abefc113e..b04d381a8 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -52,6 +52,7 @@ import qualified Remote.GCrypt import Annex.Path import Creds import Annex.CatFile +import Messages.Progress import Control.Concurrent import Control.Concurrent.MSampleVar @@ -354,9 +355,11 @@ dropKey r key {- Tries to copy a key's content from a remote's annex to a file. -} copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool -copyFromRemote r key file dest _p = copyFromRemote' r key file dest -copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool -copyFromRemote' r key file dest +copyFromRemote r key file dest p = metered (Just p) key $ + copyFromRemote' r key file dest + +copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool +copyFromRemote' r key file dest meterupdate | not $ Git.repoIsUrl (repo r) = guardUsable (repo r) (return False) $ do params <- Ssh.rsyncParams r Download u <- getUUID @@ -434,7 +437,9 @@ copyFromRemote' r key file dest send bytes forever $ send =<< readSV v - let feeder = writeSV v . fromBytesProcessed + let feeder = \n -> do + meterupdate n + writeSV v (fromBytesProcessed n) let cleanup = do void $ tryIO $ killThread tid tryNonAsync $ @@ -451,7 +456,7 @@ copyFromRemoteCheap r key file liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True | Git.repoIsSsh (repo r) = ifM (Annex.Content.preseedTmp key file) - ( copyFromRemote' r key Nothing file + ( metered Nothing key $ copyFromRemote' r key Nothing file , return False ) | otherwise = return False diff --git a/Types/Messages.hs b/Types/Messages.hs index a437d86ef..c3696c015 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -9,7 +9,7 @@ module Types.Messages where import Data.Default -data OutputType = NormalOutput | QuietOutput | ProgressOutput | JSONOutput +data OutputType = NormalOutput | QuietOutput | ParallelOutput Int | JSONOutput data SideActionBlock = NoBlock | StartBlock | InBlock deriving (Eq) |