diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/BranchChange.hs | 21 | ||||
| -rw-r--r-- | Assistant/Threads/ConfigMonitor.hs | 90 | ||||
| -rw-r--r-- | Assistant/Threads/Merger.hs | 27 |
3 files changed, 126 insertions, 12 deletions
diff --git a/Assistant/BranchChange.hs b/Assistant/BranchChange.hs new file mode 100644 index 000000000..b166c8777 --- /dev/null +++ b/Assistant/BranchChange.hs @@ -0,0 +1,21 @@ +{- git-annex assistant git-annex branch change tracking + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.BranchChange where + +import Control.Concurrent.MSampleVar + +type BranchChangeHandle = MSampleVar () + +newBranchChangeHandle :: IO BranchChangeHandle +newBranchChangeHandle = newEmptySV + +branchChanged :: BranchChangeHandle -> IO () +branchChanged = flip writeSV () + +waitBranchChange :: BranchChangeHandle -> IO () +waitBranchChange = readSV diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs new file mode 100644 index 000000000..1dcf44b2d --- /dev/null +++ b/Assistant/Threads/ConfigMonitor.hs @@ -0,0 +1,90 @@ +{- git-annex assistant config monitor thread + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.ConfigMonitor where + +import Assistant.Common +import Assistant.BranchChange +import Assistant.ThreadedMonad +import Assistant.DaemonStatus +import Utility.ThreadScheduler +import Logs.UUID +import Logs.Trust +import Logs.Remote +import Logs.PreferredContent +import Logs.Group +import Remote.List (remoteListRefresh) +import qualified Git +import qualified Git.LsTree as LsTree +import qualified Annex.Branch +import qualified Annex + +import qualified Data.Set as S + +thisThread :: ThreadName +thisThread = "ConfigMonitor" + +{- This thread detects when configuration changes have been made to the + - git-annex branch and reloads cached configuration. + - + - If the branch is frequently changing, it's checked for configuration + - changes no more often than once every 60 seconds. On the other hand, + - if the branch has not changed in a while, configuration changes will + - be detected immediately. + -} +configMonitorThread :: ThreadState -> DaemonStatusHandle -> BranchChangeHandle -> NamedThread +configMonitorThread st dstatus branchhandle = thread $ do + r <- runThreadState st Annex.gitRepo + go r =<< getConfigs r + where + thread = NamedThread thisThread + + go r old = do + threadDelaySeconds (Seconds 60) + waitBranchChange branchhandle + new <- getConfigs r + when (old /= new) $ do + let changedconfigs = new `S.difference` old + debug thisThread $ "reloading config" : + map fst (S.toList changedconfigs) + reloadConfigs st dstatus changedconfigs + go r new + +{- Config files, and their checksums. -} +type Configs = S.Set (FilePath, String) + +{- All git-annex's config files, and actions to run when they change. -} +configFilesActions :: [(FilePath, Annex ())] +configFilesActions = + [ (uuidLog, void $ uuidMapLoad) + , (remoteLog, void remoteListRefresh) + , (trustLog, void trustMapLoad) + , (groupLog, void groupMapLoad) + -- Preferred content settings depend on most of the other configs, + -- so will be reloaded whenever any configs change. + , (preferredContentLog, noop) + ] + +reloadConfigs :: ThreadState -> DaemonStatusHandle -> Configs -> IO () +reloadConfigs st dstatus changedconfigs = runThreadState st $ do + sequence_ as + void preferredContentMapLoad + {- Changes to the remote log, or the trust log, can affect the + - syncRemotes list -} + when (Logs.Remote.remoteLog `elem` fs || Logs.Trust.trustLog `elem` fs) $ + updateSyncRemotes dstatus + where + (fs, as) = unzip $ filter (flip S.member changedfiles . fst) + configFilesActions + changedfiles = S.map fst changedconfigs + +getConfigs :: Git.Repo -> IO Configs +getConfigs r = S.fromList . map extract + <$> LsTree.lsTreeFiles Annex.Branch.fullname files r + where + files = map fst configFilesActions + extract treeitem = (LsTree.file treeitem, LsTree.sha treeitem) diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 46f516262..e415a7562 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -11,6 +11,7 @@ import Assistant.Common import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.TransferQueue +import Assistant.BranchChange import Utility.DirWatcher import Utility.Types.DirWatcher import qualified Annex.Branch @@ -23,12 +24,12 @@ thisThread = "Merger" {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} -mergeThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread -mergeThread st dstatus transferqueue = thread $ do +mergeThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> BranchChangeHandle -> NamedThread +mergeThread st dstatus transferqueue branchchange = thread $ do g <- runThreadState st gitRepo let dir = Git.localGitDir g </> "refs" createDirectoryIfMissing True dir - let hook a = Just $ runHandler st dstatus transferqueue a + let hook a = Just $ runHandler st dstatus transferqueue branchchange a let hooks = mkWatchHooks { addHook = hook onAdd , errHook = hook onErr @@ -38,21 +39,21 @@ mergeThread st dstatus transferqueue = thread $ do where thread = NamedThread thisThread -type Handler = ThreadState -> DaemonStatusHandle -> TransferQueue -> FilePath -> Maybe FileStatus -> IO () +type Handler = ThreadState -> DaemonStatusHandle -> TransferQueue -> BranchChangeHandle -> FilePath -> Maybe FileStatus -> IO () {- Runs an action handler. - - Exceptions are ignored, otherwise a whole thread could be crashed. -} -runHandler :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Handler -> FilePath -> Maybe FileStatus -> IO () -runHandler st dstatus transferqueue handler file filestatus = void $ +runHandler :: ThreadState -> DaemonStatusHandle -> TransferQueue -> BranchChangeHandle -> Handler -> FilePath -> Maybe FileStatus -> IO () +runHandler st dstatus transferqueue branchchange handler file filestatus = void $ either print (const noop) =<< tryIO go where - go = handler st dstatus transferqueue file filestatus + go = handler st dstatus transferqueue branchchange file filestatus {- Called when there's an error with inotify. -} onErr :: Handler -onErr _ _ _ msg _ = error msg +onErr _ _ _ _ msg _ = error msg {- Called when a new branch ref is written. - @@ -66,11 +67,13 @@ onErr _ _ _ msg _ = error msg - ran are merged in. -} onAdd :: Handler -onAdd st dstatus transferqueue file _ +onAdd st dstatus transferqueue branchchange file _ | ".lock" `isSuffixOf` file = noop - | isAnnexBranch file = runThreadState st $ - whenM Annex.Branch.forceUpdate $ - queueDeferredDownloads Later transferqueue dstatus + | isAnnexBranch file = do + branchChanged branchchange + runThreadState st $ + whenM Annex.Branch.forceUpdate $ + queueDeferredDownloads Later transferqueue dstatus | "/synced/" `isInfixOf` file = runThreadState st $ do mergecurrent =<< inRepo Git.Branch.current | otherwise = noop |