webapp: Improved alerts displayed when syncing with remotes, and when syncing with a remote fails.

5 files changed, 78 insertions, 62 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 4e733428a..54ac750e9 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 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 ()
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index d87aa8d3b..e90cca1ec 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 d4ccf411a..d328ba197 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 79bb33b0e..1242c1d74 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 ()