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.
This commit is contained in:
Joey Hess 2012-09-19 16:55:08 -04:00
parent aff09a1f33
commit e1037adebc
2 changed files with 25 additions and 10 deletions

View file

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