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:
Joey Hess 2012-10-20 16:37:06 -04:00
parent b281584422
commit c7c2015435
14 changed files with 216 additions and 63 deletions

View file

@ -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

View file

@ -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

21
Assistant/BranchChange.hs Normal file
View file

@ -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

View 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)

View file

@ -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,9 +67,11 @@ 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 $
| isAnnexBranch file = do
branchChanged branchchange
runThreadState st $
whenM Annex.Branch.forceUpdate $
queueDeferredDownloads Later transferqueue dstatus
| "/synced/" `isInfixOf` file = runThreadState st $ do

View file

@ -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

View file

@ -6,10 +6,12 @@
-}
module Logs.Group (
groupLog,
groupChange,
groupSet,
lookupGroups,
groupMap,
groupMapLoad,
getStandardGroup,
) where
@ -47,13 +49,13 @@ 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
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

View file

@ -6,9 +6,11 @@
-}
module Logs.PreferredContent (
preferredContentLog,
preferredContentSet,
isPreferredContent,
preferredContentMap,
preferredContentMapLoad,
preferredContentMapRaw,
checkPreferredContentExpression,
setStandardGroup,
@ -60,14 +62,15 @@ 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

View file

@ -6,6 +6,7 @@
-}
module Logs.Remote (
remoteLog,
readRemoteLog,
configSet,
keyValToConfig,

View file

@ -6,11 +6,13 @@
-}
module Logs.Trust (
trustLog,
TrustLevel(..),
trustGet,
trustSet,
trustPartition,
lookupTrust,
trustMapLoad,
trustMapRaw,
) where
@ -65,14 +67,14 @@ 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
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
@ -86,6 +88,8 @@ trustMap = do
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

View file

@ -8,34 +8,38 @@
-
- uuid.log stores a list of known uuids, and their descriptions.
-
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- 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

View file

@ -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

3
debian/changelog vendored
View file

@ -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".

View file

@ -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