From 9a58cbabc8fb30b181da48191a87ba6520e0fb0c Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 27 Jan 2013 22:43:05 +1100
Subject: annex.autocommit

New setting, can be used to disable autocommit of changed files by the
assistant, while it still does data syncing and other tasks.

Also wired into webapp UI
---
 Assistant/Threads/Watcher.hs | 41 +++++++++++++++++++++++++++++++++++++++--
 1 file changed, 39 insertions(+), 2 deletions(-)

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

diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 2c61b50f5..9c0439231 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -5,8 +5,11 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module Assistant.Threads.Watcher (
 	watchThread,
+	WatcherException(..),
 	checkCanWatch,
 	needLsof,
 	stageSymlink,
@@ -38,9 +41,12 @@ import Annex.Content.Direct
 import Annex.CatFile
 import Git.Types
 import Config
+import Utility.ThreadScheduler
 
 import Data.Bits.Utils
+import Data.Typeable
 import qualified Data.ByteString.Lazy as L
+import qualified Control.Exception as E
 
 checkCanWatch :: Annex ()
 checkCanWatch
@@ -58,8 +64,21 @@ needLsof = error $ unlines
 	, "Be warned: This can corrupt data in the annex, and make fsck complain."
 	]
 
+{- A special exception that can be thrown to pause or resume the watcher. -}
+data WatcherException = PauseWatcher | ResumeWatcher
+        deriving (Show, Eq, Typeable)
+
+instance E.Exception WatcherException
+
 watchThread :: NamedThread
-watchThread = namedThread "Watcher" $ do
+watchThread = namedThread "Watcher" $
+	ifM (liftAnnex $ annexAutoCommit <$> Annex.getGitConfig)
+		( runWatcher
+		, waitFor ResumeWatcher runWatcher
+		)
+
+runWatcher :: Assistant ()
+runWatcher = do
 	startup <- asIO1 startupScan
 	direct <- liftAnnex isDirect
 	addhook <- hook $ if direct then onAddDirect else onAdd
@@ -74,11 +93,29 @@ watchThread = namedThread "Watcher" $ do
 		, delDirHook = deldirhook
 		, errHook = errhook
 		}
-	void $ liftIO $ watchDir "." ignored hooks startup
+	handle <- liftIO $ watchDir "." ignored hooks startup
 	debug [ "watching", "."]
+	
+	{- Let the DirWatcher thread run until signalled to pause it,
+	 - then wait for a resume signal, and restart. -}
+	waitFor PauseWatcher $ do
+		liftIO $ stopWatchDir handle
+		waitFor ResumeWatcher runWatcher
   where
 	hook a = Just <$> asIO2 (runHandler a)
 
+waitFor :: WatcherException -> Assistant () -> Assistant ()
+waitFor sig next = do
+	r <- liftIO $ (E.try pause :: IO (Either E.SomeException ()))
+	case r of
+		Left e -> case E.fromException e of
+			Just s
+				| s == sig -> next
+			_ -> noop
+		_ -> noop
+  where
+	pause = runEvery (Seconds 86400) noop
+
 {- Initial scartup scan. The action should return once the scan is complete. -}
 startupScan :: IO a -> Assistant a
 startupScan scanner = do
-- 
cgit v1.2.3