diff options
| -rw-r--r-- | Assistant/NamedThread.hs | 5 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 41 | ||||
| -rw-r--r-- | Config.hs | 2 | ||||
| -rw-r--r-- | Git/Config.hs | 4 | ||||
| -rw-r--r-- | Types/GitConfig.hs | 2 | ||||
| -rw-r--r-- | debian/changelog | 3 | ||||
| -rw-r--r-- | doc/git-annex.mdwn | 5 |
7 files changed, 59 insertions, 3 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 @@ -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. -} diff --git a/Git/Config.hs b/Git/Config.hs index 52a9dafb5..adc75a208 100644 --- a/Git/Config.hs +++ b/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 diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index f93ef1529..30214bc29 100644 --- a/Types/GitConfig.hs +++ b/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 diff --git a/debian/changelog b/debian/changelog index df3021d69..d7b89c2dd 100644 --- a/debian/changelog +++ b/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 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 7294fb277..e55f97fc2 100644 --- a/doc/git-annex.mdwn +++ b/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 |