summaryrefslogtreecommitdiff
path: root/Assistant/Sync.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-03-18 16:19:42 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-03-18 17:23:47 -0400
commitaa26294c303846f4022a8750a148863646c9fdde (patch)
tree44d3a64c1c3c964f0bca5b56b03df53269f8fed0 /Assistant/Sync.hs
parent4d035de8f4618e1c31c837b151b7ffeced20cd3d (diff)
webapp: Improved alerts displayed when syncing with remotes, and when syncing with a remote fails.
Diffstat (limited to 'Assistant/Sync.hs')
-rw-r--r--Assistant/Sync.hs86
1 files changed, 52 insertions, 34 deletions
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 39c30d108..25fa44a69 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -48,31 +48,27 @@ reconnectRemotes _ [] = noop
reconnectRemotes notifypushes rs = void $ do
modifyDaemonStatus_ $ \s -> s
{ desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) }
- if null normalremotes
- then go
- else alertWhile (syncAlert normalremotes) go
+ syncAction rs (const go)
where
gitremotes = filter (notspecialremote . Remote.repo) rs
- (xmppremotes, normalremotes) = partition isXMPPRemote gitremotes
- nonxmppremotes = snd $ partition isXMPPRemote rs
+ (xmppremotes, nonxmppremotes) = partition isXMPPRemote rs
notspecialremote r
| Git.repoIsUrl r = True
| Git.repoIsLocal r = True
+ | Git.repoIsLocalUnknown r = True
| otherwise = False
sync (Just branch) = do
- diverged <- snd <$> manualPull (Just branch) gitremotes
+ (failedpull, diverged) <- manualPull (Just branch) gitremotes
now <- liftIO getCurrentTime
- ok <- pushToRemotes' now notifypushes gitremotes
- return (ok, diverged)
+ failedpush <- pushToRemotes' now notifypushes gitremotes
+ return (nub $ failedpull ++ failedpush, diverged)
{- No local branch exists yet, but we can try pulling. -}
- sync Nothing = do
- diverged <- snd <$> manualPull Nothing gitremotes
- return (True, diverged)
+ sync Nothing = manualPull Nothing gitremotes
go = do
- (ok, diverged) <- sync
+ (failed, diverged) <- sync
=<< liftAnnex (inRepo Git.Branch.current)
addScanRemotes diverged nonxmppremotes
- return ok
+ return failed
{- Updates the local sync branch, then pushes it to all remotes, in
- parallel, along with the git-annex branch. This is the same
@@ -96,16 +92,14 @@ reconnectRemotes notifypushes rs = void $ do
- fallback mode, where our push is guarenteed to succeed if the remote is
- reachable. If the fallback fails, the push is queued to be retried
- later.
+ -
+ - Returns any remotes that it failed to push to.
-}
-pushToRemotes :: Bool -> [Remote] -> Assistant Bool
+pushToRemotes :: Bool -> [Remote] -> Assistant [Remote]
pushToRemotes notifypushes remotes = do
- now <- liftIO $ getCurrentTime
- let nonxmppremotes = snd $ partition isXMPPRemote remotes
- let go = pushToRemotes' now notifypushes remotes
- if null nonxmppremotes
- then go
- else alertWhile (syncAlert nonxmppremotes) go
-pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant Bool
+ now <- liftIO getCurrentTime
+ syncAction remotes (pushToRemotes' now notifypushes)
+pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote]
pushToRemotes' now notifypushes remotes = do
(g, branch, u) <- liftAnnex $ do
Annex.Branch.commit "update"
@@ -119,8 +113,8 @@ pushToRemotes' now notifypushes remotes = do
sendNetMessage $ Pushing (getXMPPClientID r) CanPush
return ret
where
- go _ Nothing _ _ _ = return True -- no branch, so nothing to do
- go _ _ _ _ [] = return True -- no remotes, so nothing to do
+ go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
+ go _ _ _ _ [] = return [] -- no remotes, so nothing to do
go shouldretry (Just branch) g u rs = do
debug ["pushing to", show rs]
liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
@@ -131,7 +125,7 @@ pushToRemotes' now notifypushes remotes = do
when notifypushes $
sendNetMessage $ NotifyPush $
map Remote.uuid succeeded
- return True
+ return failed
else if shouldretry
then retry branch g u failed
else fallback branch g u failed
@@ -154,30 +148,54 @@ pushToRemotes' now notifypushes remotes = do
when (notifypushes && (not $ null succeeded)) $
sendNetMessage $ NotifyPush $
map Remote.uuid succeeded
- return $ null failed
+ return failed
push g branch remote = Command.Sync.pushBranch remote branch g
-{- Manually pull from remotes and merge their branches. Returns the results
- - of all the pulls, and whether the git-annex branches of the remotes and
- - local had divierged before the pull.
+{- Displays an alert while running an action that syncs with some remotes,
+ - and returns any remotes that it failed to sync with.
+ -
+ - XMPP remotes are handled specially; since the action can only start
+ - an async process for them, they are not included in the alert, but are
+ - still passed to the action.
+ -}
+syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote]
+syncAction rs a
+ | null nonxmppremotes = a rs
+ | otherwise = do
+ i <- addAlert $ syncAlert nonxmppremotes
+ failed <- a rs
+ let succeeded = filter (`notElem` failed) nonxmppremotes
+ updateAlertMap $ mergeAlert i $
+ syncResultAlert succeeded failed
+ return failed
+ where
+ nonxmppremotes = filter (not . isXMPPRemote) rs
+
+{- Manually pull from remotes and merge their branches. Returns any
+ - remotes that it failed to pull from, and a Bool indicating
+ - whether the git-annex branches of the remotes and local had
+ - diverged before the pull.
-
- - After pulling from the normal git remotes, requests pushes from any XMPP
- - remotes. However, those pushes will run asynchronously, so their
+ - After pulling from the normal git remotes, requests pushes from any
+ - XMPP remotes. However, those pushes will run asynchronously, so their
- results are not included in the return data.
-}
-manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Bool], Bool)
+manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool)
manualPull currentbranch remotes = do
g <- liftAnnex gitRepo
let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
- results <- liftIO $ forM normalremotes $ \r ->
- Git.Command.runBool [Param "fetch", Param $ Remote.name r] g
+ failed <- liftIO $ forM normalremotes $ \r ->
+ ifM (Git.Command.runBool [Param "fetch", Param $ Remote.name r] g)
+ ( return Nothing
+ , return $ Just r
+ )
haddiverged <- liftAnnex Annex.Branch.forceUpdate
forM_ normalremotes $ \r ->
liftAnnex $ Command.Sync.mergeRemote r currentbranch
forM_ xmppremotes $ \r ->
sendNetMessage $ Pushing (getXMPPClientID r) PushRequest
- return (results, haddiverged)
+ return (catMaybes failed, haddiverged)
{- Start syncing a newly added remote, using a background thread. -}
syncNewRemote :: Remote -> Assistant ()