diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-11-14 16:27:39 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-11-14 16:40:49 -0400 |
commit | a38d1ae1fb3b3d1b42ee5b8ed878d574180c544f (patch) | |
tree | 29923061b31bf0a715af34c38cf304dc714f4d5a /Remote | |
parent | 0298701d0018b0baa933761657751e0c26dc39d1 (diff) |
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.
Diffstat (limited to 'Remote')
-rw-r--r-- | Remote/Git.hs | 33 | ||||
-rw-r--r-- | Remote/Helper/Special.hs | 8 | ||||
-rw-r--r-- | Remote/P2P.hs | 11 |
3 files changed, 26 insertions, 26 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs index 30307d037..da2ecee57 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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) diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index ae654d517..f7e9759a4 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -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 diff --git a/Remote/P2P.hs b/Remote/P2P.hs index be0d4589f..83ce258de 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -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 |