From 4bc070f7bf8f86ff7c3bba3dc1245401c5ddf7a9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 11 Mar 2013 15:46:09 -0400
Subject: better handling of batch renames

Rather than wait a full second, which may be longer than needed, or too
short to get all the rename events, we start a mode where we wait 1/10th of
a second, and if there are Changes received, wait again. Basically we're
back in batch mode when this happens.
---
 Assistant/Threads/Committer.hs | 35 ++++++++++++++++++++++-------------
 1 file changed, 22 insertions(+), 13 deletions(-)

(limited to 'Assistant/Threads/Committer.hs')

diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index 029ac94d2..08d34dd06 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -80,22 +80,11 @@ waitChangeTime a = runEvery (Seconds 1) <~> do
 	changes <- getChanges
 	-- See if now's a good time to commit.
 	now <- liftIO getCurrentTime
-	debug ["got", show changes]
 	case (shouldCommit now changes, possiblyrename changes) of
 		(True, False) -> a (changes, now)
 		(True, True) -> do
-			{- Wait for other, related changes to arrive.
-			 - If there are multiple RmChanges, this is
-			 - probably a directory rename, so wait a full
-			 - second to get all the Changes involved. -}
-			liftIO $ if length (filter isRmChange changes) > 1
-				then threadDelaySeconds $ Seconds 1
-				else humanImperceptibleDelay
-			-- Don't block, but are there any new changes?
-			morechanges <- getAnyChanges
-			debug ["got more", show morechanges]
-			let allchanges = changes++morechanges
-			a (allchanges, now)
+			morechanges <- getrelatedchanges changes
+			a (changes ++ morechanges, now)
 		_ -> refill changes
   where
 	{- Did we perhaps only get one of the AddChange and RmChange pair
@@ -107,6 +96,26 @@ waitChangeTime a = runEvery (Seconds 1) <~> do
 	renamepart (PendingAddChange _ _) = True
 	renamepart c = isRmChange c
 
+	{- Gets changes related to the passed changes, without blocking
+	 - very long.
+	 -
+	 - If there are multiple RmChanges, this is probably a directory
+	 - rename, in which case it may be necessary to wait longer to get
+	 - all the Changes involved.
+	 -}
+	getrelatedchanges oldchanges
+		| length (filter isRmChange oldchanges) > 1 =
+			concat <$> getbatchchanges []
+		| otherwise = do
+			liftIO humanImperceptibleDelay
+			getAnyChanges
+	getbatchchanges cs = do
+		liftIO $ threadDelay $ fromIntegral $ oneSecond `div` 10
+		cs' <- getAnyChanges
+		if null cs'
+			then return cs
+			else getbatchchanges (cs':cs)
+
 isRmChange :: Change -> Bool
 isRmChange (Change { changeInfo = i }) | i == RmChange = True
 isRmChange _ = False
-- 
cgit v1.2.3