make metered more generic
Allow it to be used when the Key is not known.
This commit is contained in:
parent
8355dba5cc
commit
26c54d6ea3
4 changed files with 39 additions and 22 deletions
|
@ -360,7 +360,7 @@ downloadImport remote importtreeconfig importablecontents = do
|
|||
Nothing -> return Nothing
|
||||
checkDiskSpaceToGet tmpkey Nothing $
|
||||
withTmp tmpkey $ \tmpfile ->
|
||||
metered Nothing tmpkey (return Nothing) $
|
||||
metered Nothing tmpkey $
|
||||
const (rundownload tmpfile)
|
||||
where
|
||||
ia = Remote.importActions remote
|
||||
|
|
|
@ -1,10 +1,12 @@
|
|||
{- git-annex progress output
|
||||
-
|
||||
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module Messages.Progress where
|
||||
|
||||
import Common
|
||||
|
@ -19,16 +21,38 @@ import Messages.Concurrent
|
|||
import qualified System.Console.Regions as Regions
|
||||
import qualified System.Console.Concurrent as Console
|
||||
|
||||
{- Shows a progress meter while performing a transfer of a key.
|
||||
- The action is passed the meter and a callback to use to update the meter.
|
||||
-
|
||||
- When the key's size is not known, the srcfile is statted to get the size.
|
||||
{- Class of things from which a size can be gotten to display a progress
|
||||
- meter. -}
|
||||
class MeterSize t where
|
||||
getMeterSize :: t -> Annex (Maybe Integer)
|
||||
|
||||
instance MeterSize (Maybe Integer) where
|
||||
getMeterSize = pure
|
||||
|
||||
instance MeterSize Key where
|
||||
getMeterSize = pure . keySize
|
||||
|
||||
{- 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 FilePath))
|
||||
|
||||
instance MeterSize KeySizer where
|
||||
getMeterSize (KeySizer k getsrcfile) = case keySize k of
|
||||
Just sz -> return (Just sz)
|
||||
Nothing -> do
|
||||
srcfile <- getsrcfile
|
||||
case srcfile of
|
||||
Nothing -> return Nothing
|
||||
Just f -> catchMaybeIO $ liftIO $ 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 :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (Meter -> MeterUpdate -> Annex a) -> Annex a
|
||||
metered othermeter key getsrcfile a = withMessageState $ \st ->
|
||||
flip go st =<< getsz
|
||||
metered :: MeterSize sizer => Maybe MeterUpdate -> sizer -> (Meter -> MeterUpdate -> Annex a) -> Annex a
|
||||
metered othermeter sizer a = withMessageState $ \st ->
|
||||
flip go st =<< getMeterSize sizer
|
||||
where
|
||||
go _ (MessageState { outputType = QuietOutput }) = nometer
|
||||
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
|
||||
|
@ -66,19 +90,11 @@ metered othermeter key getsrcfile a = withMessageState $ \st ->
|
|||
combinemeter m = case othermeter of
|
||||
Nothing -> m
|
||||
Just om -> combineMeterUpdate m om
|
||||
|
||||
getsz = case keySize key of
|
||||
Just sz -> return (Just sz)
|
||||
Nothing -> do
|
||||
srcfile <- getsrcfile
|
||||
case srcfile of
|
||||
Nothing -> return Nothing
|
||||
Just f -> catchMaybeIO $ liftIO $ getFileSize f
|
||||
|
||||
{- Poll file size to display meter. -}
|
||||
meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
|
||||
meteredFile file combinemeterupdate key a =
|
||||
metered combinemeterupdate key (return Nothing) $ \_ p ->
|
||||
metered combinemeterupdate key $ \_ p ->
|
||||
watchFileSize file p a
|
||||
|
||||
{- Progress dots. -}
|
||||
|
|
|
@ -32,14 +32,14 @@ type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) ->
|
|||
|
||||
store :: (MeterUpdate -> ProtoRunner Bool) -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
store runner k af p = do
|
||||
let getsrcfile = fmap fst <$> prepSendAnnex k
|
||||
metered (Just p) k getsrcfile $ \_ p' ->
|
||||
let sizer = KeySizer k (fmap fst <$> prepSendAnnex k)
|
||||
metered (Just p) sizer $ \_ p' ->
|
||||
fromMaybe False
|
||||
<$> runner p' (P2P.put k af p')
|
||||
|
||||
retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
|
||||
retrieve runner k af dest p =
|
||||
metered (Just p) k (return Nothing) $ \m p' ->
|
||||
metered (Just p) k $ \m p' ->
|
||||
fromMaybe (False, UnVerified)
|
||||
<$> runner p' (P2P.get dest k af m p')
|
||||
|
||||
|
|
|
@ -253,7 +253,8 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
chunkconfig = chunkConfig cfg
|
||||
|
||||
displayprogress p k srcfile a
|
||||
| displayProgress cfg = metered (Just p) k (return srcfile) (const a)
|
||||
| displayProgress cfg =
|
||||
metered (Just p) (KeySizer k (return srcfile)) (const a)
|
||||
| otherwise = a p
|
||||
|
||||
{- Sink callback for retrieveChunks. Stores the file content into the
|
||||
|
|
Loading…
Add table
Reference in a new issue