diff options
author | Joey Hess <joey@kitenet.net> | 2013-01-27 22:43:05 +1100 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2013-01-27 22:43:05 +1100 |
commit | 9a58cbabc8fb30b181da48191a87ba6520e0fb0c (patch) | |
tree | b64107b98ecc0d779291cad90fada13d0f6f4bf6 /Assistant | |
parent | 3bd8fba2db932b7730ba497d60030db6ee6f6405 (diff) |
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
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/NamedThread.hs | 5 | ||||
-rw-r--r-- | Assistant/Threads/Watcher.hs | 41 |
2 files changed, 44 insertions, 2 deletions
diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index fbb7da4c2..fd710cf54 100644 --- a/Assistant/NamedThread.hs +++ b/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 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 |