Display progress meter when uploading a key without size information
Getting the size by statting the content file. This commit was supported by the NSF-funded DataLad project.
This commit is contained in:
Joey Hess
parent
b5e1534c5c
commit
f5edb16729
8 changed files with 76 additions and 45 deletions
|
|
@ -1,3 +1,10 @@
|
|||
git-annex (6.20171110) UNRELEASED; urgency=medium
|
||||
|
||||
* Display progress meter when uploading a key without size information,
|
||||
getting the size by statting the content file.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Tue, 14 Nov 2017 16:14:20 -0400
|
||||
|
||||
git-annex (6.20171109) unstable; urgency=medium
|
||||
|
||||
* Fix export of subdir of a branch.
|
||||
|
|
|
|||
|
|
@ -215,20 +215,20 @@ performExport r ea db ek af contentsha loc = do
|
|||
let storer = storeExport ea
|
||||
sent <- case ek of
|
||||
AnnexKey k -> ifM (inAnnex k)
|
||||
( metered Nothing k $ \m -> do
|
||||
let rollback = void $
|
||||
performUnexport r ea db [ek] loc
|
||||
notifyTransfer Upload af $
|
||||
upload (uuid r) k af noRetry $ \pm -> do
|
||||
let m' = combineMeterUpdate pm m
|
||||
sendAnnex k rollback
|
||||
(\f -> storer f k loc m')
|
||||
( notifyTransfer Upload af $
|
||||
upload (uuid r) k af noRetry $ \pm -> do
|
||||
let rollback = void $
|
||||
performUnexport r ea db [ek] loc
|
||||
sendAnnex k rollback $ \f ->
|
||||
metered Nothing k (return $ Just f) $ \m -> do
|
||||
let m' = combineMeterUpdate pm m
|
||||
storer f k loc m'
|
||||
, do
|
||||
showNote "not available"
|
||||
return False
|
||||
)
|
||||
-- Sending a non-annexed file.
|
||||
GitKey sha1k -> metered Nothing sha1k $ \m ->
|
||||
GitKey sha1k -> metered Nothing sha1k (return Nothing) $ \m ->
|
||||
withTmpFile "export" $ \tmp h -> do
|
||||
b <- catObject contentsha
|
||||
liftIO $ L.hPut h b
|
||||
|
|
|
|||
|
|
@ -24,12 +24,18 @@ import qualified System.Console.Concurrent as Console
|
|||
#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 -> (MeterUpdate -> Annex a) -> Annex a
|
||||
metered othermeter key a = withMessageState $ go (keySize key)
|
||||
- The action is passed a callback to use to update the meter.
|
||||
-
|
||||
- When the key's size is not known, the srcfile is statted to get the size.
|
||||
- This allows uploads of keys without size to still have progress
|
||||
- displayed.
|
||||
--}
|
||||
metered :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (MeterUpdate -> Annex a) -> Annex a
|
||||
metered othermeter key getsrcfile a = withMessageState $ \st ->
|
||||
flip go st =<< getsz
|
||||
where
|
||||
go _ (MessageState { outputType = QuietOutput }) = nometer
|
||||
go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
|
||||
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
|
||||
showOutput
|
||||
meter <- liftIO $ mkMeter msize bandwidthMeter $
|
||||
displayMeterHandle stdout
|
||||
|
|
@ -38,7 +44,7 @@ metered othermeter key a = withMessageState $ go (keySize key)
|
|||
r <- a (combinemeter m)
|
||||
liftIO $ clearMeterHandle meter stdout
|
||||
return r
|
||||
go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
|
||||
go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =
|
||||
#if WITH_CONCURRENTOUTPUT
|
||||
withProgressRegion $ \r -> do
|
||||
meter <- liftIO $ mkMeter msize bandwidthMeter $ \_ s ->
|
||||
|
|
@ -61,14 +67,22 @@ metered othermeter key a = withMessageState $ go (keySize key)
|
|||
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
|
||||
|
||||
{- Use when the command's own progress output is preferred.
|
||||
- The command's output will be suppressed and git-annex's progress meter
|
||||
- used for concurrent output, and json progress. -}
|
||||
commandMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
|
||||
commandMetered combinemeterupdate key a =
|
||||
commandMetered :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (MeterUpdate -> Annex a) -> Annex a
|
||||
commandMetered combinemeterupdate key getsrcfile a =
|
||||
withMessageState $ \s -> if needOutputMeter s
|
||||
then metered combinemeterupdate key a
|
||||
then metered combinemeterupdate key getsrcfile a
|
||||
else a (fromMaybe nullMeterUpdate combinemeterupdate)
|
||||
|
||||
{- Poll file size to display meter, but only when concurrent output or
|
||||
|
|
@ -76,7 +90,7 @@ commandMetered combinemeterupdate key a =
|
|||
meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
|
||||
meteredFile file combinemeterupdate key a =
|
||||
withMessageState $ \s -> if needOutputMeter s
|
||||
then metered combinemeterupdate key $ \p ->
|
||||
then metered combinemeterupdate key (return Nothing) $ \p ->
|
||||
watchFileSize file p a
|
||||
else a
|
||||
|
||||
|
|
|
|||
|
|
@ -435,7 +435,7 @@ copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate ->
|
|||
copyFromRemote r key file dest p
|
||||
| Git.repoIsHttp (repo r) = unVerified $
|
||||
Annex.Content.downloadUrl key p (keyUrls r key) dest
|
||||
| otherwise = commandMetered (Just p) key $
|
||||
| otherwise = commandMetered (Just p) key (return Nothing) $
|
||||
copyFromRemote' r key file dest
|
||||
|
||||
copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
|
||||
|
|
@ -546,27 +546,24 @@ copyFromRemoteCheap _ _ _ _ = return False
|
|||
|
||||
{- Tries to copy a key's content to a remote's annex. -}
|
||||
copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
copyToRemote r key file meterupdate =
|
||||
commandMetered (Just meterupdate) key $
|
||||
copyToRemote' r key file
|
||||
|
||||
copyToRemote' :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
copyToRemote' r key file meterupdate
|
||||
copyToRemote r key file meterupdate
|
||||
| not $ Git.repoIsUrl (repo r) =
|
||||
guardUsable (repo r) (return False) $ commitOnCleanup r $
|
||||
copylocal =<< Annex.Content.prepSendAnnex key
|
||||
| Git.repoIsSsh (repo r) = commitOnCleanup r $
|
||||
Annex.Content.sendAnnex key noop $ \object -> do
|
||||
-- This is too broad really, but recvkey normally
|
||||
-- verifies content anyway, so avoid complicating
|
||||
-- it with a local sendAnnex check and rollback.
|
||||
unlocked <- isDirect <||> versionSupportsUnlockedPointers
|
||||
Ssh.rsyncHelper (Just meterupdate)
|
||||
=<< Ssh.rsyncParamsRemote unlocked r Upload key object file
|
||||
Annex.Content.sendAnnex key noop $ \object ->
|
||||
withmeter object $ \p -> do
|
||||
-- This is too broad really, but recvkey normally
|
||||
-- verifies content anyway, so avoid complicating
|
||||
-- it with a local sendAnnex check and rollback.
|
||||
unlocked <- isDirect <||> versionSupportsUnlockedPointers
|
||||
Ssh.rsyncHelper (Just p)
|
||||
=<< Ssh.rsyncParamsRemote unlocked r Upload key object file
|
||||
| otherwise = giveup "copying to non-ssh repo not supported"
|
||||
where
|
||||
withmeter object = commandMetered (Just meterupdate) key (return $ Just object)
|
||||
copylocal Nothing = return False
|
||||
copylocal (Just (object, checksuccess)) = do
|
||||
copylocal (Just (object, checksuccess)) = withmeter object $ \p -> do
|
||||
-- The checksuccess action is going to be run in
|
||||
-- the remote's Annex, but it needs access to the local
|
||||
-- Annex monad's state.
|
||||
|
|
@ -581,11 +578,11 @@ copyToRemote' r key file meterupdate
|
|||
ensureInitialized
|
||||
copier <- mkCopier hardlink params
|
||||
let verify = Annex.Content.RemoteVerify r
|
||||
runTransfer (Transfer Download u key) file forwardRetry $ \p ->
|
||||
let p' = combineMeterUpdate meterupdate p
|
||||
runTransfer (Transfer Download u key) file forwardRetry $ \p' ->
|
||||
let p'' = combineMeterUpdate p p'
|
||||
in Annex.Content.saveState True `after`
|
||||
Annex.Content.getViaTmp verify key
|
||||
(\dest -> copier object dest p' (liftIO checksuccessio))
|
||||
(\dest -> copier object dest p'' (liftIO checksuccessio))
|
||||
)
|
||||
|
||||
fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
|
||||
|
|
|
|||
|
|
@ -187,7 +187,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
go (Just storer) = preparecheckpresent k $ safely . go' storer
|
||||
go Nothing = return False
|
||||
go' storer (Just checker) = sendAnnex k rollback $ \src ->
|
||||
displayprogress p k $ \p' ->
|
||||
displayprogress p k (Just src) $ \p' ->
|
||||
storeChunks (uuid baser) chunkconfig enck k src p'
|
||||
(storechunk enc storer)
|
||||
checker
|
||||
|
|
@ -207,7 +207,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
retrieveKeyFileGen k dest p enc =
|
||||
safely $ prepareretriever k $ safely . go
|
||||
where
|
||||
go (Just retriever) = displayprogress p k $ \p' ->
|
||||
go (Just retriever) = displayprogress p k Nothing $ \p' ->
|
||||
retrieveChunks retriever (uuid baser) chunkconfig
|
||||
enck k dest p' (sink dest enc encr)
|
||||
go Nothing = return False
|
||||
|
|
@ -227,8 +227,8 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
|
||||
chunkconfig = chunkConfig cfg
|
||||
|
||||
displayprogress p k a
|
||||
| displayProgress cfg = metered (Just p) k a
|
||||
displayprogress p k srcfile a
|
||||
| displayProgress cfg = metered (Just p) k (return srcfile) a
|
||||
| otherwise = a p
|
||||
|
||||
{- Sink callback for retrieveChunks. Stores the file content into the
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ import Types.Remote
|
|||
import Types.GitConfig
|
||||
import qualified Git
|
||||
import Annex.UUID
|
||||
import Annex.Content
|
||||
import Config
|
||||
import Config.Cost
|
||||
import Remote.Helper.Git
|
||||
|
|
@ -78,13 +79,15 @@ chainGen addr r u c gc = do
|
|||
return (Just this)
|
||||
|
||||
store :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
store u addr connpool k af p =
|
||||
metered (Just p) k $ \p' -> fromMaybe False
|
||||
<$> runProto u addr connpool (P2P.put k af p')
|
||||
store u addr connpool k af p = do
|
||||
let getsrcfile = fmap fst <$> prepSendAnnex k
|
||||
metered (Just p) k getsrcfile $ \p' ->
|
||||
fromMaybe False
|
||||
<$> runProto u addr connpool (P2P.put k af p')
|
||||
|
||||
retrieve :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
|
||||
retrieve u addr connpool k af dest p = unVerified $
|
||||
metered (Just p) k $ \p' -> fromMaybe False
|
||||
metered (Just p) k (return Nothing) $ \p' -> fromMaybe False
|
||||
<$> runProto u addr connpool (P2P.get dest k af p')
|
||||
|
||||
remove :: UUID -> P2PAddress -> ConnectionPool -> Key -> Annex Bool
|
||||
|
|
|
|||
|
|
@ -20,4 +20,5 @@ lrwxrwxrwx 1 yoh yoh 150 Nov 3 09:02 Why_is_git_annex_awesome__This_is_why_.web
|
|||
|
||||
"""]]
|
||||
|
||||
|
||||
> [[done]], but see my caveat about needing to handle lack of progress
|
||||
> output anyway. --[[Joey]]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
[[!comment format=mdwn
|
||||
username="joey"
|
||||
subject="""comment 3"""
|
||||
date="2017-11-14T20:17:10Z"
|
||||
content="""
|
||||
I suppose that, since some remotes don't have progress display implemented,
|
||||
in paricular some external special remotes, there's no point in worrying
|
||||
about interface consistency. So, may as well display progress when we can.
|
||||
"""]]
|
||||
Loading…
Reference in a new issue