From c7c201543579e6247e885a4280f67df9810122f9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 20 Oct 2012 16:37:06 -0400 Subject: [PATCH] add ConfigMonitor thread Monitors git-annex branch for changes, which are noticed by the Merger thread whenever the branch ref is changed (either due to an incoming push, or a local change), and refreshes cached config values for modified config files. Rate limited to run no more often than once per minute. This is important because frequent git-annex branch changes happen when files are being added, or transferred, etc. A primary use case is that, when preferred content changes are made, and get pushed to remotes, the remotes start honoring those settings. Other use cases include propigating repository description and trust changes to remotes, and learning when a remote has added a new special remote, so the webapp can present the GUI to enable that special remote locally. Also added a uuid.log cache. All other config files already had caches. --- Annex.hs | 2 + Assistant.hs | 11 ++- Assistant/BranchChange.hs | 21 +++++ Assistant/Threads/ConfigMonitor.hs | 90 ++++++++++++++++++++++ Assistant/Threads/Merger.hs | 27 ++++--- Git/LsTree.hs | 8 +- Logs/Group.hs | 24 +++--- Logs/PreferredContent.hs | 25 +++--- Logs/Remote.hs | 1 + Logs/Trust.hs | 32 ++++---- Logs/UUID.hs | 28 ++++--- Types/UUID.hs | 4 + debian/changelog | 3 + doc/design/assistant/transfer_control.mdwn | 3 - 14 files changed, 216 insertions(+), 63 deletions(-) create mode 100644 Assistant/BranchChange.hs create mode 100644 Assistant/Threads/ConfigMonitor.hs diff --git a/Annex.hs b/Annex.hs index 1cadaed512..f1897e1e69 100644 --- a/Annex.hs +++ b/Annex.hs @@ -101,6 +101,7 @@ data AnnexState = AnnexState , forcebackend :: Maybe String , forcenumcopies :: Maybe Int , limit :: Matcher (FileInfo -> Annex Bool) + , uuidmap :: Maybe UUIDMap , preferredcontentmap :: Maybe PreferredContentMap , shared :: Maybe SharedRepository , forcetrust :: TrustMap @@ -129,6 +130,7 @@ newState gitrepo = AnnexState , forcebackend = Nothing , forcenumcopies = Nothing , limit = Left [] + , uuidmap = Nothing , preferredcontentmap = Nothing , shared = Nothing , forcetrust = M.empty diff --git a/Assistant.hs b/Assistant.hs index 8b326c8b59..6e24573acd 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -66,7 +66,10 @@ - Uses the ScanRemotes map.a - Thread 17: PairListener - Listens for incoming pairing traffic, and takes action. - - Thread 18: WebApp + - Thread 18: ConfigMonitor + - Triggered by changes to the git-annex branch, checks for changed + - config files, and reloads configs. + - Thread 19: WebApp - Spawns more threads as necessary to handle clients. - Displays the DaemonStatus. - @@ -114,6 +117,7 @@ import Assistant.Changes import Assistant.Commits import Assistant.Pushes import Assistant.ScanRemotes +import Assistant.BranchChange import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Threads.DaemonStatus @@ -128,6 +132,7 @@ import Assistant.Threads.MountWatcher import Assistant.Threads.NetWatcher import Assistant.Threads.TransferScanner import Assistant.Threads.TransferPoller +import Assistant.Threads.ConfigMonitor #ifdef WITH_WEBAPP import Assistant.WebApp import Assistant.Threads.WebApp @@ -174,6 +179,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do transferqueue <- newTransferQueue transferslots <- newTransferSlots scanremotes <- newScanRemoteMap + branchhandle <- newBranchChangeHandle #ifdef WITH_WEBAPP urlrenderer <- newUrlRenderer #endif @@ -187,7 +193,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do #endif , assist $ pushThread st dstatus commitchan pushmap , assist $ pushRetryThread st dstatus pushmap - , assist $ mergeThread st dstatus transferqueue + , assist $ mergeThread st dstatus transferqueue branchhandle , assist $ transferWatcherThread st dstatus transferqueue , assist $ transferPollerThread st dstatus , assist $ transfererThread st dstatus transferqueue transferslots @@ -197,6 +203,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do , assist $ netWatcherThread st dstatus scanremotes , assist $ netWatcherFallbackThread st dstatus scanremotes , assist $ transferScannerThread st dstatus scanremotes transferqueue + , assist $ configMonitorThread st dstatus branchhandle , watch $ watchThread st dstatus transferqueue changechan ] waitForTermination diff --git a/Assistant/BranchChange.hs b/Assistant/BranchChange.hs new file mode 100644 index 0000000000..b166c87778 --- /dev/null +++ b/Assistant/BranchChange.hs @@ -0,0 +1,21 @@ +{- git-annex assistant git-annex branch change tracking + - + - Copyright 2012 Joey Hess + - + - 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 0000000000..1dcf44b2da --- /dev/null +++ b/Assistant/Threads/ConfigMonitor.hs @@ -0,0 +1,90 @@ +{- git-annex assistant config monitor thread + - + - Copyright 2012 Joey Hess + - + - 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 46f516262e..e415a75626 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 diff --git a/Git/LsTree.hs b/Git/LsTree.hs index dc03b88960..64187b89b8 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -8,6 +8,7 @@ module Git.LsTree ( TreeItem(..), lsTree, + lsTreeFiles, parseLsTree ) where @@ -27,11 +28,16 @@ data TreeItem = TreeItem , file :: FilePath } deriving Show -{- Lists the contents of a Ref -} +{- Lists the complete contents of a tree. -} lsTree :: Ref -> Repo -> IO [TreeItem] lsTree t repo = map parseLsTree <$> pipeNullSplitZombie [Params "ls-tree --full-tree -z -r --", File $ show t] repo +{- Lists specified files in a tree. -} +lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] +lsTreeFiles t fs repo = map parseLsTree <$> + pipeNullSplitZombie ([Params "ls-tree -z --", File $ show t] ++ map File fs) repo + {- Parses a line of ls-tree output. - (The --long format is not currently supported.) -} parseLsTree :: String -> TreeItem diff --git a/Logs/Group.hs b/Logs/Group.hs index 9fd7486505..de0d1e598b 100644 --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -6,10 +6,12 @@ -} module Logs.Group ( + groupLog, groupChange, groupSet, lookupGroups, groupMap, + groupMapLoad, getStandardGroup, ) where @@ -47,18 +49,18 @@ groupChange NoUUID _ = error "unknown UUID; cannot modify" groupSet :: UUID -> S.Set Group -> Annex () groupSet u g = groupChange u (const g) -{- Read the groupLog into a map. The map is cached for speed. -} +{- The map is cached for speed. -} groupMap :: Annex GroupMap -groupMap = do - cached <- Annex.getState Annex.groupmap - case cached of - Just m -> return m - Nothing -> do - m <- makeGroupMap . simpleMap . - parseLog (Just . S.fromList . words) <$> - Annex.Branch.get groupLog - Annex.changeState $ \s -> s { Annex.groupmap = Just m } - return m +groupMap = maybe groupMapLoad return =<< Annex.getState Annex.groupmap + +{- Loads the map, updating the cache. -} +groupMapLoad :: Annex GroupMap +groupMapLoad = do + m <- makeGroupMap . simpleMap . + parseLog (Just . S.fromList . words) <$> + Annex.Branch.get groupLog + Annex.changeState $ \s -> s { Annex.groupmap = Just m } + return m makeGroupMap :: M.Map UUID (S.Set Group) -> GroupMap makeGroupMap byuuid = GroupMap byuuid bygroup diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index f3454cc7d3..003efaeae6 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -6,9 +6,11 @@ -} module Logs.PreferredContent ( + preferredContentLog, preferredContentSet, isPreferredContent, preferredContentMap, + preferredContentMapLoad, preferredContentMapRaw, checkPreferredContentExpression, setStandardGroup, @@ -60,19 +62,20 @@ isPreferredContent mu notpresent file = do Just matcher -> Utility.Matcher.matchMrun matcher $ \a -> a notpresent fi -{- Read the preferredContentLog into a map. The map is cached for speed. -} +{- The map is cached for speed. -} preferredContentMap :: Annex Annex.PreferredContentMap -preferredContentMap = do +preferredContentMap = maybe preferredContentMapLoad return + =<< Annex.getState Annex.preferredcontentmap + +{- Loads the map, updating the cache. -} +preferredContentMapLoad :: Annex Annex.PreferredContentMap +preferredContentMapLoad = do groupmap <- groupMap - cached <- Annex.getState Annex.preferredcontentmap - case cached of - Just m -> return m - Nothing -> do - m <- simpleMap - . parseLogWithUUID ((Just .) . makeMatcher groupmap) - <$> Annex.Branch.get preferredContentLog - Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } - return m + m <- simpleMap + . parseLogWithUUID ((Just .) . makeMatcher groupmap) + <$> Annex.Branch.get preferredContentLog + Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } + return m preferredContentMapRaw :: Annex (M.Map UUID String) preferredContentMapRaw = simpleMap . parseLog Just diff --git a/Logs/Remote.hs b/Logs/Remote.hs index b75573a411..d4991e2728 100644 --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -6,6 +6,7 @@ -} module Logs.Remote ( + remoteLog, readRemoteLog, configSet, keyValToConfig, diff --git a/Logs/Trust.hs b/Logs/Trust.hs index 1a29f8cf09..cd437bf89a 100644 --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -6,11 +6,13 @@ -} module Logs.Trust ( + trustLog, TrustLevel(..), trustGet, trustSet, trustPartition, lookupTrust, + trustMapLoad, trustMapRaw, ) where @@ -65,27 +67,29 @@ trustPartition level ls candidates <- trustGet level return $ partition (`elem` candidates) ls -{- Read the trustLog into a map, overriding with any - - values from forcetrust or the git config. The map is cached for speed. -} +{- trustLog in a map, overridden with any values from forcetrust or + - the git config. The map is cached for speed. -} trustMap :: Annex TrustMap -trustMap = do - cached <- Annex.getState Annex.trustmap - case cached of - Just m -> return m - Nothing -> do - overrides <- Annex.getState Annex.forcetrust - logged <- trustMapRaw - configured <- M.fromList . catMaybes - <$> (mapM configuredtrust =<< remoteList) - let m = M.union overrides $ M.union configured logged - Annex.changeState $ \s -> s { Annex.trustmap = Just m } - return m +trustMap = maybe trustMapLoad return =<< Annex.getState Annex.trustmap + +{- Loads the map, updating the cache, -} +trustMapLoad :: Annex TrustMap +trustMapLoad = do + overrides <- Annex.getState Annex.forcetrust + logged <- trustMapRaw + configured <- M.fromList . catMaybes + <$> (mapM configuredtrust =<< remoteList) + let m = M.union overrides $ M.union configured logged + Annex.changeState $ \s -> s { Annex.trustmap = Just m } + return m where configuredtrust r = maybe Nothing (\l -> Just (Types.Remote.uuid r, l)) <$> maybe Nothing readTrustLevel <$> getTrustLevel (Types.Remote.repo r) +{- Does not include forcetrust or git config values, just those from the + - log file. -} trustMapRaw :: Annex TrustMap trustMapRaw = simpleMap . parseLog (Just . parseTrustLog) <$> Annex.Branch.get trustLog diff --git a/Logs/UUID.hs b/Logs/UUID.hs index d825e11273..7b7090223b 100644 --- a/Logs/UUID.hs +++ b/Logs/UUID.hs @@ -8,34 +8,38 @@ - - uuid.log stores a list of known uuids, and their descriptions. - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Logs.UUID ( + uuidLog, describeUUID, recordUUID, - uuidMap + uuidMap, + uuidMapLoad ) where import qualified Data.Map as M import Data.Time.Clock.POSIX +import Types.UUID import Common.Annex +import qualified Annex import qualified Annex.Branch import Logs.UUIDBased import qualified Annex.UUID {- Filename of uuid.log. -} -logfile :: FilePath -logfile = "uuid.log" +uuidLog :: FilePath +uuidLog = "uuid.log" {- Records a description for a uuid in the log. -} describeUUID :: UUID -> String -> Annex () describeUUID uuid desc = do ts <- liftIO getPOSIXTime - Annex.Branch.change logfile $ + Annex.Branch.change uuidLog $ showLog id . changeLog ts uuid desc . fixBadUUID . parseLog Just {- Temporarily here to fix badly formatted uuid logs generated by @@ -76,14 +80,20 @@ recordUUID u = go . M.lookup u =<< uuidMap go _ = noop set = describeUUID u "" +{- The map is cached for speed. -} +uuidMap :: Annex UUIDMap +uuidMap = maybe uuidMapLoad return =<< Annex.getState Annex.uuidmap + {- Read the uuidLog into a simple Map. - - The UUID of the current repository is included explicitly, since - it may not have been described and so otherwise would not appear. -} -uuidMap :: Annex (M.Map UUID String) -uuidMap = do - m <- (simpleMap . parseLog Just) <$> Annex.Branch.get logfile +uuidMapLoad :: Annex UUIDMap +uuidMapLoad = do + m <- (simpleMap . parseLog Just) <$> Annex.Branch.get uuidLog u <- Annex.UUID.getUUID - return $ M.insertWith' preferold u "" m + let m' = M.insertWith' preferold u "" m + Annex.changeState $ \s -> s { Annex.uuidmap = Just m' } + return m' where preferold = flip const diff --git a/Types/UUID.hs b/Types/UUID.hs index 88c261b6e3..8a304dffab 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -7,6 +7,8 @@ module Types.UUID where +import qualified Data.Map as M + -- A UUID is either an arbitrary opaque string, or UUID info may be missing. data UUID = NoUUID | UUID String deriving (Eq, Ord, Show, Read) @@ -18,3 +20,5 @@ fromUUID NoUUID = "" toUUID :: String -> UUID toUUID [] = NoUUID toUUID s = UUID s + +type UUIDMap = M.Map UUID String diff --git a/debian/changelog b/debian/changelog index e306bdcfa3..6b3a9a0524 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,9 @@ git-annex (3.20121018) UNRELEASED; urgency=low * assistant: Now drops non-preferred content. + * assistant: Now notices, and applies config changes + as they are made to the git-annex branch, including config changes + pushed in from remotes. * Preferred content path matching bugfix. * Preferred content expressions cannot use "in=". * Preferred content expressions can use "present". diff --git a/doc/design/assistant/transfer_control.mdwn b/doc/design/assistant/transfer_control.mdwn index e3d9584f27..ad5578c502 100644 --- a/doc/design/assistant/transfer_control.mdwn +++ b/doc/design/assistant/transfer_control.mdwn @@ -10,9 +10,6 @@ something smart with such remotes. ## TODO -* preferred content settings made in the webapp (or in vicfg, - or synced over) are not noticed while the assistant is running; it has to - be restarted for them to take effect. * The expensive scan currently makes one pass, dropping content at the same time more uploads and downloads are queued. It would be better to drop as much content as possible upfront, to keep the total annex size as small