diff options
author | Joey Hess <joey@kitenet.net> | 2012-09-17 21:05:50 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-09-17 21:05:50 -0400 |
commit | 3c22977e44b852ecc4d1ad2d728e5dc9071952ae (patch) | |
tree | ef2f0d8e1635c49dea2bf4d4876e25a46981f058 /Assistant/Threads | |
parent | 7a86dc944306af4d0a707631b03ef93941ecc1be (diff) |
deferred downloads
Now when a download is queued and there's no known remote to get it from,
it's added to a deferred download list, which will be retried later.
The Merger thread tries to queue any deferred downloads when it receives
a push to the git-annex branch.
Note that the Merger thread now also forces an update of the git-annex
branch. The assistant was not updating this branch before, and it saw a
(mostly) correct view of state, but now that incoming pushes go to
synced/git-annex, it needs to be merged in.
Diffstat (limited to 'Assistant/Threads')
-rw-r--r-- | Assistant/Threads/Merger.hs | 35 |
1 files changed, 19 insertions, 16 deletions
diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index ce1ff1c7b..c2aa1f52d 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -9,6 +9,8 @@ module Assistant.Threads.Merger where import Assistant.Common import Assistant.ThreadedMonad +import Assistant.DaemonStatus +import Assistant.TransferQueue import Utility.DirWatcher import Utility.Types.DirWatcher import qualified Annex.Branch @@ -19,15 +21,14 @@ import qualified Git.Branch thisThread :: ThreadName thisThread = "Merger" -{- This thread watches for changes to .git/refs/, looking for - - incoming pushes. It merges those pushes into the currently - - checked out branch. -} -mergeThread :: ThreadState -> NamedThread -mergeThread st = thread $ do +{- This thread watches for changes to .git/refs/, and handles incoming + - pushes. -} +mergeThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread +mergeThread st dstatus transferqueue = thread $ do g <- runThreadState st $ fromRepo id let dir = Git.localGitDir g </> "refs" createDirectoryIfMissing True dir - let hook a = Just $ runHandler g a + let hook a = Just $ runHandler st dstatus transferqueue g a let hooks = mkWatchHooks { addHook = hook onAdd , errHook = hook onErr @@ -37,21 +38,21 @@ mergeThread st = thread $ do where thread = NamedThread thisThread -type Handler = Git.Repo -> FilePath -> Maybe FileStatus -> IO () +type Handler = ThreadState -> DaemonStatusHandle -> TransferQueue -> Git.Repo -> FilePath -> Maybe FileStatus -> IO () {- Runs an action handler. - - Exceptions are ignored, otherwise a whole thread could be crashed. -} -runHandler :: Git.Repo -> Handler -> FilePath -> Maybe FileStatus -> IO () -runHandler g handler file filestatus = void $ +runHandler :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Git.Repo -> Handler -> FilePath -> Maybe FileStatus -> IO () +runHandler st dstatus transferqueue g handler file filestatus = void $ either print (const noop) =<< tryIO go where - go = handler g file filestatus + go = handler st dstatus transferqueue g 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. - @@ -65,14 +66,16 @@ onErr _ msg _ = error msg - ran are merged in. -} onAdd :: Handler -onAdd g file _ +onAdd st dstatus transferqueue g file _ | ".lock" `isSuffixOf` file = noop - | isAnnexBranch file = noop - | "/synced/" `isInfixOf` file = go =<< Git.Branch.current g + | isAnnexBranch file = runThreadState st $ + whenM Annex.Branch.forceUpdate $ + queueDeferredDownloads Later transferqueue dstatus + | "/synced/" `isInfixOf` file = mergecurrent =<< Git.Branch.current g | otherwise = noop where changedbranch = fileToBranch file - go (Just current) + mergecurrent (Just current) | equivBranches changedbranch current = do liftIO $ debug thisThread [ "merging" @@ -81,7 +84,7 @@ onAdd g file _ , show current ] void $ Git.Merge.mergeNonInteractive changedbranch g - go _ = noop + mergecurrent _ = noop equivBranches :: Git.Ref -> Git.Ref -> Bool equivBranches x y = base x == base y |