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/NamedThread.hs

@@ -73,6 +73,11 @@ startNamedThread urlrenderer namedthread@(NamedThread name a) = do
 				, buttonAction = Just close
 				}
 
+namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
+namedThreadId (NamedThread name _) = do
+	m <- startedThreads <$> getDaemonStatus
+	return $ asyncThreadId . fst <$> M.lookup name m
+
 {- Waits for all named threads that have been started to finish.
  -
  - Note that if a named thread crashes, it will probably

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

Assistant/WebApp/Configurators.hs

@@ -14,6 +14,7 @@ import Assistant.DaemonStatus
 import Assistant.WebApp.Notifications
 import Assistant.WebApp.Utility
 import Assistant.WebApp.Configurators.Local
+import qualified Annex
 import qualified Remote
 import qualified Types.Remote as Remote
 import Annex.UUID (getUUID)
@@ -136,10 +137,18 @@ repoList reposelector
 		rs <- filter wantedrepo . syncRemotes
 			<$> liftAssistant getDaemonStatus
 		runAnnex [] $ do
-			u <- getUUID
+			let us = map Remote.uuid rs
-			let l = map Remote.uuid rs
+			let l = zip us $ map mkSyncingRepoActions us
-			let l' = if includeHere reposelector then u : l else l
+			if includeHere reposelector
-			return $ zip l' $ map mkSyncingRepoActions l'
+				then do
+					u <- getUUID
+					autocommit <- annexAutoCommit <$> Annex.getGitConfig
+					let hereactions = if autocommit
+						then mkSyncingRepoActions u
+						else mkNotSyncingRepoActions u
+					let here = (u, hereactions)
+					return $ here : l
+				else return l
 	rest = runAnnex [] $ do
 		m <- readRemoteLog
 		unconfigured <- map snd . catMaybes . filter wantedremote 

Assistant/WebApp/Utility.hs

@@ -22,15 +22,27 @@ import qualified Assistant.Threads.Transferrer as Transferrer
 import Logs.Transfer
 import Locations.UserConfig
 import qualified Config
+import Git.Config
+import Assistant.Threads.Watcher
+import Assistant.NamedThread
 
 import qualified Data.Map as M
 import Control.Concurrent
 import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
 import System.Posix.Process (getProcessGroupIDOf)
 
-{- Use Nothing to change global sync setting. -}
+{- Use Nothing to change autocommit setting; or a remote to change
+ - its sync setting. -}
 changeSyncable :: (Maybe Remote) -> Bool -> Handler ()
-changeSyncable Nothing _ = noop -- TODO
+changeSyncable Nothing enable = liftAssistant $ do
+	liftAnnex $ Config.setConfig key (boolConfig enable)
+	liftIO . maybe noop (`throwTo` signal)
+		=<< namedThreadId watchThread
+  where
+	key = Config.annexConfig "autocommit"
+	signal
+		| enable = ResumeWatcher
+		| otherwise = PauseWatcher
 changeSyncable (Just r) True = do
 	changeSyncFlag r True
 	syncRemote r
@@ -48,13 +60,10 @@ changeSyncable (Just r) False = do
 
 changeSyncFlag :: Remote -> Bool -> Handler ()
 changeSyncFlag r enabled = runAnnex undefined $ do
-	Config.setConfig key value
+	Config.setConfig key (boolConfig enabled)
 	void $ Remote.remoteListRefresh
   where
 	key = Config.remoteConfig (Remote.repo r) "sync"
-	value
-		| enabled = "true"
-		| otherwise = "false"
 
 {- Start syncing remote, using a background thread. -}
 syncRemote :: Remote -> Handler ()

Config.hs

@@ -83,7 +83,7 @@ isDirect = annexDirect <$> Annex.getGitConfig
 
 setDirect :: Bool -> Annex ()
 setDirect b = do
-	setConfig (annexConfig "direct") $ if b then "true" else "false"
+	setConfig (annexConfig "direct") (Git.Config.boolConfig b)
 	Annex.changeGitConfig $ \c -> c { annexDirect = b }
 
 {- Gets the http headers to use. -}

Git/Config.hs

@@ -147,5 +147,9 @@ isTrue s
   where
 	s' = map toLower s
 
+boolConfig :: Bool -> String
+boolConfig True = "true"
+boolConfig False = "false"
+
 isBare :: Repo -> Bool
 isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r

Types/GitConfig.hs

@@ -33,6 +33,7 @@ data GitConfig = GitConfig
 	, annexDelayAdd :: Maybe Int
 	, annexHttpHeaders :: [String]
 	, annexHttpHeadersCommand :: Maybe String
+	, annexAutoCommit :: Bool
 	}
 
 extractGitConfig :: Git.Repo -> GitConfig
@@ -51,6 +52,7 @@ extractGitConfig r = GitConfig
 	, annexDelayAdd = getmayberead "delayadd"
 	, annexHttpHeaders = getlist "http-headers"
 	, annexHttpHeadersCommand = getmaybe "http-headers-command"
+	, annexAutoCommit = getbool "autocommit" True
 	}
   where
 	get k def = fromMaybe def $ getmayberead k

debian/changelog

@@ -4,6 +4,9 @@ git-annex (3.20130125) UNRELEASED; urgency=low
   * Adjust debian package to only build-depend on DAV on architectures
     where it is available.
   * addurl --fast: Use curl, rather than haskell HTTP library, to support https.
+  * 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.
 
  -- Joey Hess <joeyh@debian.org>  Sat, 26 Jan 2013 15:48:40 +1100
 

doc/git-annex.mdwn

@@ -802,6 +802,11 @@ Here are all the supported configuration settings.
   are accessed directly, rather than through symlinks. Note that many git
   and git-annex commands will not work with such a repository.
 
+* `annex.autocommit`
+
+  Set to false to prevent the git-annex assistant from automatically
+  committing changes to files in the repository.
+
 * `remote.<name>.annex-cost`
 
   When determining which repository to