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.
This commit is contained in:
parent
b281584422
commit
c7c2015435
14 changed files with 216 additions and 63 deletions
90
Assistant/Threads/ConfigMonitor.hs
Normal file
90
Assistant/Threads/ConfigMonitor.hs
Normal file
|
@ -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)
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue