rsync progress interception

Current implementation parses rsync's output a character a time, which
is hardly efficient. It could be sped up a lot by using hGetBufSome,
but that would require going really lowlevel, down to raw C style buffers
(good example of that here: http://users.aber.ac.uk/afc/stricthaskell.html)
But rsync doesn't output very much, so currently it seems ok.

2 files changed, 25 insertions, 10 deletions

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 46f65ac74..80e73ede9 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -245,7 +245,7 @@ copyFromRemote r key file dest
 			loc <- inRepo $ gitAnnexLocation key
 			upload u key file $
 				rsyncOrCopyFile params loc dest
-	| Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key dest file
+	| Git.repoIsSsh r = rsyncHelper Nothing =<< rsyncParamsRemote r True key dest file
 	| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest
 	| otherwise = error "copying from non-ssh, non-http repo not supported"
 
@@ -280,13 +280,13 @@ copyToRemote r key file p
 			)
 	| Git.repoIsSsh r = commitOnCleanup r $ do
 		keysrc <- inRepo $ gitAnnexLocation key
-		rsyncHelper =<< rsyncParamsRemote r False key keysrc file
+		rsyncHelper (Just p) =<< rsyncParamsRemote r False key keysrc file
 	| otherwise = error "copying to non-ssh repo not supported"
 
-rsyncHelper :: [CommandParam] -> Annex Bool
-rsyncHelper p = do
+rsyncHelper :: Maybe ProgressCallback -> [CommandParam] -> Annex Bool
+rsyncHelper callback params = do
 	showOutput -- make way for progress bar
-	ifM (liftIO $ rsync p)
+	ifM (liftIO $ (maybe rsync rsyncProgress callback) params)
 		( return True
 		, do
 			showLongNote "rsync failed -- run git annex again to resume file transfer"
@@ -299,7 +299,7 @@ rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> ProgressCallback ->
 rsyncOrCopyFile rsyncparams src dest p =
 	ifM (sameDeviceIds src dest)
 		( liftIO $ copyFileExternal src dest
-		, rsyncHelper $ rsyncparams ++ [Param src, Param dest]
+		, rsyncHelper (Just p) $ rsyncparams ++ [Param src, Param dest]
 		)
 	where
 		sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b)
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 70be0d0bc..a533b88dd 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -7,11 +7,8 @@
 
 module Utility.Rsync where
 
-import Utility.SafeCommand
-import Utility.PartialPrelude
+import Common
 
-import Data.String.Utils
-import Data.List
 import Data.Char
 
 {- Generates parameters to make rsync use a specified command as its remote
@@ -49,6 +46,24 @@ rsyncServerParams =
 rsync :: [CommandParam] -> IO Bool
 rsync = boolSystem "rsync"
 
+{- Runs rsync, but intercepts its progress output and feeds bytes
+ - complete values into the callback. The progress output is also output
+ - to stdout. -}
+rsyncProgress :: (Integer -> IO ()) -> [CommandParam] -> IO Bool
+rsyncProgress callback params = catchBoolIO $
+	withHandle StdoutHandle createProcessSuccess p (feedprogress [])
+	where
+		p = proc "rsync" (toCommand params)
+		feedprogress buf h =
+			catchMaybeIO (hGetChar h) >>= \v -> case v of
+				Just c -> do
+					putChar c
+					hFlush stdout
+					let (mbytes, buf') = parseRsyncProgress (buf++[c])
+					maybe noop callback mbytes
+					feedprogress buf' h
+				Nothing -> return True
+
 {- Checks if an rsync url involves the remote shell (ssh or rsh).
  - Use of such urls with rsync requires additional shell
  - escaping. -}