upload progress bar for git remote on same filesystem

cp is used here, but we can just watch the size of the destination file

This commit made from within the ruins of an old mill, overlooking a
beautiful waterfall.

1 files changed, 20 insertions, 4 deletions

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 80e73ede9..cd38cac06 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -37,6 +37,8 @@ import Init
 import Types.Key
 import qualified Fields
 
+import Control.Concurrent
+
 remote :: RemoteType
 remote = RemoteType {
 	typename = "git",
@@ -297,13 +299,27 @@ rsyncHelper callback params = do
  - filesystem. Then cp could be faster. -}
 rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> ProgressCallback -> Annex Bool
 rsyncOrCopyFile rsyncparams src dest p =
-	ifM (sameDeviceIds src dest)
-		( liftIO $ copyFileExternal src dest
-		, rsyncHelper (Just p) $ rsyncparams ++ [Param src, Param dest]
-		)
+	ifM (sameDeviceIds src dest) (dorsync, docopy)
 	where
 		sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b)
 		getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f)
+		dorsync = rsyncHelper (Just p) $
+			rsyncparams ++ [Param src, Param dest]
+		docopy = liftIO $ bracket
+			(forkIO $ watchfilesize 0)
+			(void . tryIO . killThread)
+			(const $ copyFileExternal src dest)
+		watchfilesize oldsz = do
+			threadDelay 500000 -- 0.5 seconds
+			v <- catchMaybeIO $
+				fromIntegral . fileSize
+					<$> getFileStatus dest
+			case v of
+				Just sz
+					| sz /= oldsz -> do
+						p sz
+						watchfilesize sz
+				_ -> watchfilesize oldsz
 
 {- Generates rsync parameters that ssh to the remote and asks it
  - to either receive or send the key's content. -}