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.

1 files changed, 19 insertions, 4 deletions

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