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 2017-11-14 16:27:39 -04:00
parent b5e1534c5c
commit f5edb16729
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
8 changed files with 76 additions and 45 deletions

View file

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

View file

@ -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

View file

@ -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