diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs new file mode 100644 index 0000000000..68053167af --- /dev/null +++ b/Assistant/Sync.hs @@ -0,0 +1,98 @@ +{- git-annex assistant repo syncing + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Sync where + +import Assistant.Common +import Assistant.Pushes +import Assistant.Alert +import Assistant.ThreadedMonad +import Assistant.DaemonStatus +import Assistant.ScanRemotes +import qualified Command.Sync +import Utility.Parallel +import qualified Git +import qualified Git.Branch +import qualified Git.Command +import qualified Remote +import qualified Annex.Branch + +import Data.Time.Clock +import qualified Data.Map as M + +{- Syncs with remotes that may have been disconnected for a while. + - + - After getting git in sync, queues a scan for file transfers. + -} +syncRemotes :: ThreadName -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> [Remote] -> IO () +syncRemotes _ _ _ _ [] = noop +syncRemotes threadname st dstatus scanremotes rs = do + void $ alertWhile dstatus (syncAlert rs) $ do + sync =<< runThreadState st (inRepo Git.Branch.current) + addScanRemotes scanremotes rs + where + sync (Just branch) = do + runThreadState st $ manualPull (Just branch) rs + now <- getCurrentTime + pushToRemotes threadname now st Nothing rs + {- No local branch exists yet, but we can try pulling. -} + sync Nothing = do + runThreadState st $ manualPull Nothing rs + return True + +{- Updates the local sync branch, then pushes it to all remotes, in + - parallel. + - + - Avoids running possibly long-duration commands in the Annex monad, so + - as not to block other threads. -} +pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO Bool +pushToRemotes threadname now st mpushmap remotes = do + (g, branch) <- runThreadState st $ + (,) <$> fromRepo id <*> inRepo Git.Branch.current + go True branch g remotes + where + go _ Nothing _ _ = return True -- no branch, so nothing to do + go shouldretry (Just branch) g rs = do + debug threadname + [ "pushing to" + , show rs + ] + Command.Sync.updateBranch (Command.Sync.syncBranch branch) g + (succeeded, failed) <- inParallel (push g branch) rs + let ok = null failed + case mpushmap of + Nothing -> noop + Just pushmap -> + changeFailedPushMap pushmap $ \m -> + M.union (makemap failed) $ + M.difference m (makemap succeeded) + unless (ok) $ + debug threadname + [ "failed to push to" + , show failed + ] + if (ok || not shouldretry) + then return ok + else retry branch g failed + + makemap l = M.fromList $ zip l (repeat now) + + push g branch remote = Command.Sync.pushBranch remote branch g + + retry branch g rs = do + debug threadname [ "trying manual pull to resolve failed pushes" ] + runThreadState st $ manualPull (Just branch) rs + go False (Just branch) g rs + +{- Manually pull from remotes and merge their branches. -} +manualPull :: (Maybe Git.Ref) -> [Remote] -> Annex () +manualPull currentbranch remotes = do + forM_ remotes $ \r -> + inRepo $ Git.Command.runBool "fetch" [Param $ Remote.name r] + Annex.Branch.forceUpdate + forM_ remotes $ \r -> + Command.Sync.mergeRemote r currentbranch diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 6e19218d98..6c33f4f209 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -12,15 +12,13 @@ module Assistant.Threads.Merger ( import Assistant.Common import Assistant.ThreadedMonad +import Assistant.Sync import Utility.DirWatcher import Utility.Types.DirWatcher -import qualified Annex.Branch import qualified Git -import qualified Git.Command import qualified Git.Merge import qualified Git.Branch import qualified Command.Sync -import qualified Remote thisThread :: ThreadName thisThread = "Merger" @@ -84,15 +82,3 @@ onAdd g file _ mergeBranch :: Git.Ref -> Git.Repo -> IO Bool mergeBranch = Git.Merge.mergeNonInteractive . Command.Sync.syncBranch - -{- Manually pull from remotes and merge their branches. Called by the pusher - - when a push fails, which can happen due to a remote not having pushed - - changes to us. That could be because it doesn't have us as a remote, or - - because the assistant is not running there, or other reasons. -} -manualPull :: (Maybe Git.Ref) -> [Remote] -> Annex () -manualPull currentbranch remotes = do - forM_ remotes $ \r -> - inRepo $ Git.Command.runBool "fetch" [Param $ Remote.name r] - Annex.Branch.forceUpdate - forM_ remotes $ \r -> - Command.Sync.mergeRemote r currentbranch diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 82de186cc7..3de594093d 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -14,21 +14,17 @@ import Assistant.Common import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.ScanRemotes -import Assistant.Threads.Pusher (pushToRemotes) -import Assistant.Alert +import Assistant.Sync import qualified Annex import qualified Git import Utility.ThreadScheduler import Utility.Mounts import Remote.List import qualified Types.Remote as Remote -import Assistant.Threads.Merger -import qualified Git.Branch import Control.Concurrent import qualified Control.Exception as E import qualified Data.Set as S -import Data.Time.Clock #if WITH_DBUS import Utility.DBus @@ -146,23 +142,9 @@ handleMounts st dstatus scanremotes wasmounted nowmounted = handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> FilePath -> IO () handleMount st dstatus scanremotes dir = do debug thisThread ["detected mount of", dir] - rs <- remotesUnder st dstatus dir - unless (null rs) $ do - let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs - unless (null nonspecial) $ do - void $ alertWhile dstatus (syncAlert nonspecial) $ do - debug thisThread ["syncing with", show nonspecial] - sync nonspecial =<< runThreadState st (inRepo Git.Branch.current) - addScanRemotes scanremotes nonspecial - where - sync rs (Just branch) = do - runThreadState st $ manualPull (Just branch) rs - now <- getCurrentTime - pushToRemotes thisThread now st Nothing rs - {- No local branch exists yet, but we can try pulling. -} - sync rs Nothing = do - runThreadState st $ manualPull Nothing rs - return True + syncRemotes thisThread st dstatus scanremotes + =<< filter (Git.repoIsLocal . Remote.repo) + <$> remotesUnder st dstatus dir {- Finds remotes located underneath the mount point. - diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index d871a47912..ffe9e1e0a5 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -14,17 +14,13 @@ import Assistant.Common import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.ScanRemotes -import Assistant.Threads.Pusher (pushToRemotes) -import Assistant.Alert +import Assistant.Sync import qualified Git import Utility.ThreadScheduler import Remote.List import qualified Types.Remote as Remote -import Assistant.Threads.Merger -import qualified Git.Branch import qualified Control.Exception as E -import Data.Time.Clock #if WITH_DBUS import Utility.DBus @@ -128,20 +124,9 @@ pollingThread st dstatus scanremotes = runEvery (Seconds 3600) $ handleConnection :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO () handleConnection st dstatus scanremotes = do - rs <- networkRemotes st - unless (null rs) $ do - let nonspecial = filter (Git.repoIsUrl . Remote.repo) rs - unless (null nonspecial) $ do - void $ alertWhile dstatus (syncAlert nonspecial) $ do - debug thisThread ["syncing with", show nonspecial] - sync nonspecial =<< runThreadState st (inRepo Git.Branch.current) - addScanRemotes scanremotes nonspecial - where - sync rs (Just branch) = do - runThreadState st $ manualPull (Just branch) rs - now <- getCurrentTime - pushToRemotes thisThread now st Nothing rs - sync _ _ = return True + syncRemotes thisThread st dstatus scanremotes =<< + filter (Git.repoIsUrl . Remote.repo) + <$> networkRemotes st {- Finds network remotes. -} networkRemotes :: ThreadState -> IO [Remote] diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 4753e355ad..4b80297fa5 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -12,15 +12,11 @@ import Assistant.Commits import Assistant.Pushes import Assistant.Alert import Assistant.ThreadedMonad -import Assistant.Threads.Merger import Assistant.DaemonStatus -import qualified Command.Sync +import Assistant.Sync import Utility.ThreadScheduler -import Utility.Parallel -import qualified Git.Branch import Data.Time.Clock -import qualified Data.Map as M thisThread :: ThreadName thisThread = "Pusher" @@ -76,47 +72,3 @@ shouldPush :: UTCTime -> [Commit] -> Bool shouldPush _now commits | not (null commits) = True | otherwise = False - -{- Updates the local sync branch, then pushes it to all remotes, in - - parallel. - - - - Avoids running possibly long-duration commands in the Annex monad, so - - as not to block other threads. -} -pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO Bool -pushToRemotes threadname now st mpushmap remotes = do - (g, branch) <- runThreadState st $ - (,) <$> fromRepo id <*> inRepo Git.Branch.current - go True branch g remotes - where - go _ Nothing _ _ = return True -- no branch, so nothing to do - go shouldretry (Just branch) g rs = do - debug threadname - [ "pushing to" - , show rs - ] - Command.Sync.updateBranch (Command.Sync.syncBranch branch) g - (succeeded, failed) <- inParallel (push g branch) rs - let ok = null failed - case mpushmap of - Nothing -> noop - Just pushmap -> - changeFailedPushMap pushmap $ \m -> - M.union (makemap failed) $ - M.difference m (makemap succeeded) - unless (ok) $ - debug threadname - [ "failed to push to" - , show failed - ] - if (ok || not shouldretry) - then return ok - else retry branch g failed - - makemap l = M.fromList $ zip l (repeat now) - - push g branch remote = Command.Sync.pushBranch remote branch g - - retry branch g rs = do - debug threadname [ "trying manual pull to resolve failed pushes" ] - runThreadState st $ manualPull (Just branch) rs - go False (Just branch) g rs