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:
parent
b5e1534c5c
commit
f5edb16729
8 changed files with 76 additions and 45 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue