From a6504e41925ed594c95895ddf0862f817dbf1968 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 20 Sep 2012 16:01:31 -0400
Subject: [PATCH] optimised rsync output reader to read whole blocks at a time

---
 Utility/Misc.hs  | 28 +++++++++++++++++++++++++++-
 Utility/Rsync.hs | 13 +++++++------
 2 files changed, 34 insertions(+), 7 deletions(-)

diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 77ebb4f3d9..349b20efeb 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -9,6 +9,9 @@ module Utility.Misc where
 
 import System.IO
 import Control.Monad
+import Foreign
+import Data.Char
+import Control.Applicative
 
 {- A version of hgetContents that is not lazy. Ensures file is 
  - all read before it gets closed. -}
@@ -47,8 +50,31 @@ segment p l = map reverse $ go [] [] l
 			| otherwise = go (i:c) r is
 
 {- Given two orderings, returns the second if the first is EQ and returns
- - the first otherwise. -}
+ - the first otherwise.
+ -
+ - Example use:
+ -
+ - compare lname1 lname2 `thenOrd` compare fname1 fname2
+ -}
 thenOrd :: Ordering -> Ordering -> Ordering
 thenOrd EQ x = x
 thenOrd x _ = x
 {-# INLINE thenOrd #-}
+
+{- Wrapper around hGetBufSome that returns a String.
+ -
+ - The null string is returned on eof, otherwise returns whatever
+ - data is currently available to read from the handle, or waits for
+ - data to be written to it if none is currently available.
+ - 
+ - Note on encodings: The normal encoding of the Handle is ignored;
+ - each byte is converted to a Char. Not unicode clean!
+ -}
+hGetSomeString :: Handle -> Int -> IO String
+hGetSomeString h sz = do
+	fp <- mallocForeignPtrBytes sz
+	len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz
+	map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)
+	where
+		peekbytes :: Int -> Ptr Word8 -> IO [Word8]
+		peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index af76647fd3..1b022c1849 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -57,15 +57,16 @@ 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
+		feedprogress buf h = do
+			s <- hGetSomeString h 80
+			if null s
+				then return True
+				else do
+					putStr s
 					hFlush stdout
-					let (mbytes, buf') = parseRsyncProgress (buf++[c])
+					let (mbytes, buf') = parseRsyncProgress (buf++s)
 					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