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.

CHANGELOG

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

Command/Export.hs

@@ -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
+			( notifyTransfer Upload af $
-				let rollback = void $
+				upload (uuid r) k af noRetry $ \pm -> do
-					performUnexport r ea db [ek] loc
+					let rollback = void $
-				notifyTransfer Upload af $
+						performUnexport r ea db [ek] loc
-					upload (uuid r) k af noRetry $ \pm -> do
+					sendAnnex k rollback $ \f ->
-						let m' = combineMeterUpdate pm m
+						metered Nothing k (return $ Just f) $ \m -> do
-						sendAnnex k rollback
+							let m' = combineMeterUpdate pm m
-							(\f -> storer f k loc 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

Messages/Progress.hs

@@ -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. -}
+ - 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)
+ - 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 :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (MeterUpdate -> Annex a) -> Annex a
-commandMetered combinemeterupdate key 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
 

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 = 
+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
 	| 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
+		Annex.Content.sendAnnex key noop $ \object ->
-			-- This is too broad really, but recvkey normally
+			withmeter object $ \p -> do
-			-- verifies content anyway, so avoid complicating
+				-- This is too broad really, but recvkey normally
-			-- it with a local sendAnnex check and rollback.
+				-- verifies content anyway, so avoid complicating
-			unlocked <- isDirect <||> versionSupportsUnlockedPointers
+				-- it with a local sendAnnex check and rollback.
-			Ssh.rsyncHelper (Just meterupdate)
+				unlocked <- isDirect <||> versionSupportsUnlockedPointers
-				=<< Ssh.rsyncParamsRemote unlocked r Upload key object file
+				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 ->
+				runTransfer (Transfer Download u key) file forwardRetry $ \p' ->
-					let p' = combineMeterUpdate meterupdate 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)

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 p k srcfile a
-		| displayProgress cfg = metered (Just p) k a
+		| displayProgress cfg = metered (Just p) k (return srcfile) a
 		| otherwise = a p
 
 {- Sink callback for retrieveChunks. Stores the file content into the

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 = 
+store u addr connpool k af p = do
-	metered (Just p) k $ \p' -> fromMaybe False
+	let getsrcfile = fmap fst <$> prepSendAnnex k
-		<$> runProto u addr connpool (P2P.put k af p')
+	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

doc/bugs/annex_copy_might_not_report_percent-progress_when_it_has_actual_key_file.mdwn

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

doc/bugs/annex_copy_might_not_report_percent-progress_when_it_has_actual_key_file/comment_3_5866f9e2f21151f36d4fcf1b7d0ea83e._comment

@@ -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.
+"""]]