diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 4e733428af..54ac750e98 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -35,6 +35,7 @@ data AlertName | PairAlert String | XMPPNeededAlert | CloudRepoNeededAlert + | SyncAlert deriving (Eq) {- The first alert is the new alert, the second is an old alert. @@ -239,26 +240,28 @@ commitAlert = activityAlert Nothing showRemotes :: [Remote] -> TenseChunk showRemotes = UnTensed . T.unwords . map (T.pack . Remote.name) -pushRetryAlert :: [Remote] -> Alert -pushRetryAlert rs = activityAlert - (Just $ tenseWords [Tensed "Retrying" "Retried", "sync"]) - ["with", showRemotes rs] - syncAlert :: [Remote] -> Alert syncAlert rs = baseActivityAlert - { alertHeader = Just $ tenseWords + { alertName = Just SyncAlert + , alertHeader = Just $ tenseWords [Tensed "Syncing" "Synced", "with", showRemotes rs] - , alertData = [] , alertPriority = Low } -scanAlert :: [Remote] -> Alert -scanAlert rs = baseActivityAlert - { alertHeader = Just $ tenseWords - [Tensed "Scanning" "Scanned", showRemotes rs] - , alertBlockDisplay = True - , alertPriority = Low - } +syncResultAlert :: [Remote] -> [Remote] -> Alert +syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $ + baseActivityAlert + { alertName = Just SyncAlert + , alertHeader = Just $ tenseWords msg + } + where + msg + | null succeeded = ["Failed to sync with", showRemotes failed] + | null failed = ["Synced with", showRemotes succeeded] + | otherwise = + [ "Synced with", showRemotes succeeded + , "but not with", showRemotes failed + ] sanityCheckAlert :: Alert sanityCheckAlert = activityAlert diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 39c30d1081..25fa44a692 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. - - - After pulling from the normal git remotes, requests pushes from any XMPP - - remotes. However, those pushes will run asynchronously, so their + - 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 - 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 () diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index d87aa8d3b8..e90cca1ec8 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -11,7 +11,6 @@ import Assistant.Common import Assistant.Commits import Assistant.Types.Commits import Assistant.Pushes -import Assistant.Alert import Assistant.DaemonStatus import Assistant.Sync import Utility.ThreadScheduler @@ -25,8 +24,7 @@ pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do topush <- getFailedPushesBefore (fromIntegral halfhour) unless (null topush) $ do debug ["retrying", show (length topush), "failed pushes"] - void $ alertWhile (pushRetryAlert topush) $ - pushToRemotes True topush + void $ pushToRemotes True topush where halfhour = 1800 diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index d4ccf411ab..d328ba197e 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -12,7 +12,6 @@ import Assistant.Types.ScanRemotes import Assistant.ScanRemotes import Assistant.TransferQueue import Assistant.DaemonStatus -import Assistant.Alert import Assistant.Drop import Assistant.Sync import Logs.Transfer @@ -100,15 +99,13 @@ failedTransferScan r = do expensiveScan :: [Remote] -> Assistant () expensiveScan rs = unless onlyweb $ do debug ["starting scan of", show visiblers] - void $ alertWhile (scanAlert visiblers) $ do - g <- liftAnnex gitRepo - (files, cleanup) <- liftIO $ LsFiles.inRepo [] g - forM_ files $ \f -> do - ts <- maybe (return []) (findtransfers f) - =<< liftAnnex (Backend.lookupFile f) - mapM_ (enqueue f) ts - void $ liftIO cleanup - return True + g <- liftAnnex gitRepo + (files, cleanup) <- liftIO $ LsFiles.inRepo [] g + forM_ files $ \f -> do + ts <- maybe (return []) (findtransfers f) + =<< liftAnnex (Backend.lookupFile f) + mapM_ (enqueue f) ts + void $ liftIO cleanup debug ["finished scan of", show visiblers] where onlyweb = all (== webUUID) $ map Remote.uuid rs diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 79bb33b0e3..1242c1d740 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -256,7 +256,7 @@ pull us = do pullone [] _ = noop pullone (r:rs) branch = - unlessM (all id . fst <$> manualPull branch [r]) $ + unlessM (null . fst <$> manualPull branch [r]) $ pullone rs branch pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant () diff --git a/debian/changelog b/debian/changelog index d80ea4acf2..fae68c806d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -21,6 +21,8 @@ git-annex (4.20130315) UNRELEASED; urgency=low to the network, or connecting a drive. * assistant: Fix OSX bug that prevented committing changed files to a repository when in indirect mode. + * webapp: Improved alerts displayed when syncing with remotes, and + when syncing with a remote fails. -- Joey Hess Fri, 15 Mar 2013 00:10:07 -0400 diff --git a/doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn b/doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn index dad961d9fa..dca16e4d37 100644 --- a/doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn +++ b/doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn @@ -3,3 +3,6 @@ In a red bubble it says: "Synced with rose 60justin" That verbage is the same if they all succeed. The only difference is the red instead of green. Would be nice to know exactly which machine to kick (if I didn't already know, eg I was syncing only with repositories not under my control). + +> Fixed alert display. Webapp has allowed pausing syncing with a repository +> for a while. [[done]] --[[Joey]]