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.

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