2012-06-22 21:01:08 +00:00
|
|
|
{- git-annex assistant git merge thread
|
|
|
|
-
|
|
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
2012-06-23 05:20:40 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
2012-06-22 21:01:08 +00:00
|
|
|
-}
|
|
|
|
|
2012-08-26 18:14:12 +00:00
|
|
|
module Assistant.Threads.Merger where
|
2012-06-22 21:01:08 +00:00
|
|
|
|
2012-07-20 23:29:59 +00:00
|
|
|
import Assistant.Common
|
2012-09-18 01:05:50 +00:00
|
|
|
import Assistant.TransferQueue
|
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.
2012-10-20 20:37:06 +00:00
|
|
|
import Assistant.BranchChange
|
2012-06-22 21:01:08 +00:00
|
|
|
import Utility.DirWatcher
|
|
|
|
import Utility.Types.DirWatcher
|
2012-09-16 22:53:13 +00:00
|
|
|
import qualified Annex.Branch
|
2012-06-22 21:01:08 +00:00
|
|
|
import qualified Git
|
|
|
|
import qualified Git.Branch
|
2012-12-25 18:10:07 +00:00
|
|
|
import qualified Command.Sync
|
2012-06-22 21:01:08 +00:00
|
|
|
|
2012-07-20 23:29:59 +00:00
|
|
|
thisThread :: ThreadName
|
|
|
|
thisThread = "Merger"
|
|
|
|
|
2012-09-18 01:05:50 +00:00
|
|
|
{- This thread watches for changes to .git/refs/, and handles incoming
|
|
|
|
- pushes. -}
|
2012-10-29 15:40:22 +00:00
|
|
|
mergeThread :: NamedThread
|
|
|
|
mergeThread = NamedThread "Merger" $ do
|
|
|
|
g <- liftAnnex gitRepo
|
2012-09-17 03:09:08 +00:00
|
|
|
let dir = Git.localGitDir g </> "refs"
|
2012-10-29 15:40:22 +00:00
|
|
|
liftIO $ createDirectoryIfMissing True dir
|
|
|
|
let hook a = Just <$> asIO2 (runHandler a)
|
|
|
|
addhook <- hook onAdd
|
|
|
|
errhook <- hook onErr
|
2012-06-22 21:01:08 +00:00
|
|
|
let hooks = mkWatchHooks
|
2012-10-29 15:40:22 +00:00
|
|
|
{ addHook = addhook
|
|
|
|
, errHook = errhook
|
2012-06-22 21:01:08 +00:00
|
|
|
}
|
2012-10-29 15:40:22 +00:00
|
|
|
void $ liftIO $ watchDir dir (const False) hooks id
|
|
|
|
debug ["watching", dir]
|
2012-06-22 21:01:08 +00:00
|
|
|
|
2012-10-29 15:40:22 +00:00
|
|
|
type Handler = FilePath -> Assistant ()
|
2012-06-22 21:01:08 +00:00
|
|
|
|
|
|
|
{- Runs an action handler.
|
|
|
|
-
|
|
|
|
- Exceptions are ignored, otherwise a whole thread could be crashed.
|
|
|
|
-}
|
2012-10-29 15:40:22 +00:00
|
|
|
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
|
|
|
|
runHandler handler file _filestatus =
|
|
|
|
either (liftIO . print) (const noop) =<< tryIO <~> handler file
|
2012-06-22 21:01:08 +00:00
|
|
|
|
|
|
|
{- Called when there's an error with inotify. -}
|
|
|
|
onErr :: Handler
|
2012-10-29 15:40:22 +00:00
|
|
|
onErr msg = error msg
|
2012-06-22 21:01:08 +00:00
|
|
|
|
|
|
|
{- Called when a new branch ref is written.
|
|
|
|
-
|
|
|
|
- This relies on git's atomic method of updating branch ref files,
|
|
|
|
- which is to first write the new file to .lock, and then rename it
|
|
|
|
- over the old file. So, ignore .lock files, and the rename ensures
|
|
|
|
- the watcher sees a new file being added on each update.
|
|
|
|
-
|
|
|
|
- At startup, synthetic add events fire, causing this to run, but that's
|
|
|
|
- ok; it ensures that any changes pushed since the last time the assistant
|
|
|
|
- ran are merged in.
|
|
|
|
-}
|
|
|
|
onAdd :: Handler
|
2012-10-29 15:40:22 +00:00
|
|
|
onAdd file
|
2012-06-22 21:01:08 +00:00
|
|
|
| ".lock" `isSuffixOf` file = noop
|
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.
2012-10-20 20:37:06 +00:00
|
|
|
| isAnnexBranch file = do
|
2012-10-29 23:20:54 +00:00
|
|
|
branchChanged
|
2012-10-30 21:14:26 +00:00
|
|
|
whenM (liftAnnex Annex.Branch.forceUpdate) $
|
|
|
|
queueDeferredDownloads Later
|
2012-10-29 15:40:22 +00:00
|
|
|
| "/synced/" `isInfixOf` file = do
|
|
|
|
mergecurrent =<< liftAnnex (inRepo Git.Branch.current)
|
2012-09-16 22:53:13 +00:00
|
|
|
| otherwise = noop
|
2012-10-29 15:40:22 +00:00
|
|
|
where
|
|
|
|
changedbranch = fileToBranch file
|
|
|
|
mergecurrent (Just current)
|
|
|
|
| equivBranches changedbranch current = do
|
|
|
|
debug
|
|
|
|
[ "merging", show changedbranch
|
|
|
|
, "into", show current
|
|
|
|
]
|
2012-12-25 18:10:07 +00:00
|
|
|
void $ liftAnnex $ Command.Sync.mergeFrom changedbranch
|
2012-10-29 15:40:22 +00:00
|
|
|
mergecurrent _ = noop
|
2012-09-16 22:53:13 +00:00
|
|
|
|
|
|
|
equivBranches :: Git.Ref -> Git.Ref -> Bool
|
|
|
|
equivBranches x y = base x == base y
|
2012-10-31 06:34:03 +00:00
|
|
|
where
|
|
|
|
base = takeFileName . show
|
2012-06-22 21:01:08 +00:00
|
|
|
|
2012-09-16 22:53:13 +00:00
|
|
|
isAnnexBranch :: FilePath -> Bool
|
|
|
|
isAnnexBranch f = n `isSuffixOf` f
|
2012-10-31 06:34:03 +00:00
|
|
|
where
|
|
|
|
n = "/" ++ show Annex.Branch.name
|
2012-09-16 22:53:13 +00:00
|
|
|
|
|
|
|
fileToBranch :: FilePath -> Git.Ref
|
2012-09-17 03:09:08 +00:00
|
|
|
fileToBranch f = Git.Ref $ "refs" </> base
|
2012-10-31 06:34:03 +00:00
|
|
|
where
|
|
|
|
base = Prelude.last $ split "/refs/" f
|