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

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
+syncResultAlert :: [Remote] -> [Remote] -> Alert
-scanAlert rs = baseActivityAlert
+syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $
-	{ alertHeader = Just $ tenseWords
+	baseActivityAlert
-		[Tensed "Scanning" "Scanned", showRemotes rs]
+		{ alertName = Just SyncAlert
-	, alertBlockDisplay = True
+		, alertHeader = Just $ tenseWords msg
-	, alertPriority = Low
+		}
-	}
+  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

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
+	syncAction rs (const go)
-		then go
-		else alertWhile (syncAlert normalremotes) go
   where
 	gitremotes = filter (notspecialremote . Remote.repo) rs
-	(xmppremotes, normalremotes) = partition isXMPPRemote gitremotes
+	(xmppremotes, nonxmppremotes) = partition isXMPPRemote rs
-	nonxmppremotes = snd $ 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
+		failedpush <- pushToRemotes' now notifypushes gitremotes
-		return (ok, diverged)
+		return (nub $ failedpull ++ failedpush, diverged)
 	{- No local branch exists yet, but we can try pulling. -}
-	sync Nothing = do
+	sync Nothing = manualPull Nothing gitremotes
-		diverged <- snd <$> manualPull Nothing gitremotes
-		return (True, diverged)
 	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
+	now <- liftIO getCurrentTime
-	let nonxmppremotes = snd $ partition isXMPPRemote remotes
+	syncAction remotes (pushToRemotes' now notifypushes)
-	let go = pushToRemotes' now notifypushes remotes
+pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote]
-	if null nonxmppremotes
-		then go
-		else alertWhile (syncAlert nonxmppremotes) go
-pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant Bool
 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 _ Nothing _ _ _ = return [] -- no branch, so nothing to do
-	go _ _ _ _ [] = return True -- no remotes, 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
+{- Displays an alert while running an action that syncs with some remotes,
- - of all the pulls, and whether the git-annex branches of the remotes and
+ - and returns any remotes that it failed to sync with.
- - local had divierged before the pull.
  -
- - After pulling from the normal git remotes, requests pushes from any XMPP
+ - XMPP remotes are handled specially; since the action can only start
- - remotes. However, those pushes will run asynchronously, so their
+ - 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 ->
+	failed <- liftIO $ forM normalremotes $ \r ->
-		Git.Command.runBool [Param "fetch", Param $ Remote.name r] g
+		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 ()

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) $
+		void $ pushToRemotes True topush
-			pushToRemotes True topush
   where
 	halfhour = 1800
 

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
-		g <- liftAnnex gitRepo
+	(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
-		(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
+	forM_ files $ \f -> do
-		forM_ files $ \f -> do
+		ts <- maybe (return []) (findtransfers f)
-			ts <- maybe (return []) (findtransfers f)
+			=<< liftAnnex (Backend.lookupFile f)
-				=<< liftAnnex (Backend.lookupFile f)
+		mapM_ (enqueue f) ts
-			mapM_ (enqueue f) ts
+	void $ liftIO cleanup
-		void $ liftIO cleanup
-		return True
 	debug ["finished scan of", show visiblers]
   where
 	onlyweb = all (== webUUID) $ map Remote.uuid rs

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 ()

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 <joeyh@debian.org>  Fri, 15 Mar 2013 00:10:07 -0400
 

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]]