4ac2fd0a22
I now have this topology working:
assistant ---> {bare repo, special remote} <--- assistant
And, I think, also this one:
+----------- bare repo --------+
v v
assistant ---> special remote <--- assistant
While before with assistant <---> assistant connections, both sides got
location info updated after a transfer, in this topology, the bare repo
*might* get its location info updated, but the other assistant has no way to
know that it did. And a special remote doesn't record location info,
so transfers to it won't propigate out location log changes at all.
So, for these to work, after a transfer succeeds, the git-annex branch
needs to be pushed. This is done by recording a synthetic commit has
occurred, which lets the pusher handle pushing out the change (which will
include actually committing any still journalled changes to the git-annex
branch).
Of course, this means rather a lot more syncing action than happened
before. At least the pusher bundles together very close together pushes,
somewhat. Currently it just waits 2 seconds between each push.
94 lines
3 KiB
Haskell
94 lines
3 KiB
Haskell
{- 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 Assistant.Commits
|
|
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 -> CommitChan -> NamedThread
|
|
configMonitorThread st dstatus branchhandle commitchan = 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
|
|
{- Record a commit to get this config
|
|
- change pushed out to remotes. -}
|
|
recordCommit commitchan
|
|
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)
|