deletion

When a new file is annexed, a deletion event occurs when it's moved away
to be replaced by a symlink. Most of the time, there is no problimatic
race, because the same thread runs the add event as the deletion event.
So, once the symlink is in place, the deletion code won't run at all,
due to existing checks that a deleted file is really gone.

But there is a race at startup, as then the inotify thread is running
at the same time as the main thread, which does the initial tree walking
and annexing. It would be possible for the deletion inotify to run
in a perfect race with the addition, and remove the newly added symlink
from the git cache.

To solve this race, added event serialization via a MVar. We putMVar
before running each event, which blocks if an event is already running.
And when an event finishes (or crashes!), we takeMVar to free the lock.

Also, make rm -rf not spew warnings by passing --ignore-unmatch when
deleting directories.

Command/Watch.hs

@@ -44,8 +44,11 @@ start = notBareRepo $ do
 		gitdir dir = takeFileName dir /= ".git"
 
 {- Inotify events are run in separate threads, and so each is a
- - self-contained Annex monad. Exceptions by the handlers are ignored,
+ - self-contained Annex monad.
- - otherwise a whole watcher thread could be crashed. -}
+ -
+ - Exceptions by the handlers are ignored,
+ - otherwise a whole watcher thread could be crashed.
+ -}
 run :: Annex.AnnexState -> (FilePath -> Annex a) -> FilePath -> IO ()
 run startstate a f = do
 	r <- E.try go :: IO (Either E.SomeException ())
@@ -89,10 +92,11 @@ onAddSymlink file = go =<< Backend.lookupFile file
 			[Params "--force --", File file]
 
 onDel :: FilePath -> Annex ()
-onDel file = liftIO $ print $ "del " ++ file
+onDel file = inRepo $ Git.Command.run "rm"
+	[Params "--quiet --cached --", File file]
 
-{- A directory has been deleted, so tell git to remove anything that
+{- A directory has been deleted, or moved, so tell git to remove anything
-   was inside it from its cache. -}
+ - that was inside it from its cache. -}
 onDelDir :: FilePath -> Annex ()
 onDelDir dir = inRepo $ Git.Command.run "rm"
-	[Params "--quiet -r --cached --", File dir]
+	[Params "--quiet -r --cached --ignore-unmatch --", File dir]

Utility/Inotify.hs

@@ -15,6 +15,7 @@ import qualified System.Posix.Files as Files
 import System.Posix.Terminal
 import Control.Concurrent.MVar
 import System.Posix.Signals
+import Control.Exception as E
 
 type Hook = Maybe (FilePath -> IO ())
 
@@ -51,10 +52,13 @@ type Hook = Maybe (FilePath -> IO ())
 watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> Hook -> Hook -> Hook -> Hook -> IO ()
 watchDir i dir ignored add addsymlink del deldir
 	| ignored dir = noop
-	| otherwise = void $ do
+	| otherwise = do
-		_ <- addWatch i watchevents dir go
+		mvar <- newEmptyMVar
-		mapM walk =<< filter (not . dirCruft) <$>
+		void $ addWatch i watchevents dir $ \event ->
-			getDirectoryContents dir
+			serialized mvar (void $ go event)
+		serialized mvar $
+			mapM_ walk =<< filter (not . dirCruft) <$>
+				getDirectoryContents dir
 	where
 		recurse d = watchDir i d ignored add addsymlink del deldir
 
@@ -117,14 +121,22 @@ watchDir i dir ignored add addsymlink del deldir
 
 		filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)
 
+{- Uses an MVar to serialize an action, so that only one thread at a time
+ - runs it. -}
+serialized :: MVar () -> IO () -> IO ()
+serialized mvar a = void $ do
+	putMVar mvar () -- blocks if action already running
+	_ <- E.try a :: IO (Either E.SomeException ())
+	takeMVar mvar -- allow next action to run
+
 {- Pauses the main thread, letting children run until program termination. -}
 waitForTermination :: IO ()
 waitForTermination = do
-	mv <- newEmptyMVar
+	mvar <- newEmptyMVar
-	check softwareTermination mv
+	check softwareTermination mvar
 	whenM (queryTerminal stdInput) $
-		check keyboardSignal mv
+		check keyboardSignal mvar
-	takeMVar mv
+	takeMVar mvar
 	where
-		check sig mv = void $
+		check sig mvar = void $
-			installHandler sig (CatchOnce $ putMVar mv ()) Nothing
+			installHandler sig (CatchOnce $ putMVar mvar ()) Nothing