avoid false alert about syncing with xmpp remote

2 files changed, 16 insertions, 15 deletions

diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 835faa08c..46fc0c309 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -62,7 +62,7 @@ reconnectRemotes notifypushes rs = void $ do
 	sync (Just branch) = do
 		diverged <- snd <$> manualPull (Just branch) gitremotes
 		now <- liftIO getCurrentTime
-		ok <- pushToRemotes now notifypushes gitremotes
+		ok <- pushToRemotes' now notifypushes gitremotes
 		return (ok, diverged)
 	{- No local branch exists yet, but we can try pulling. -}
 	sync Nothing = do
@@ -97,8 +97,16 @@ reconnectRemotes notifypushes rs = void $ do
  - reachable. If the fallback fails, the push is queued to be retried
  - later.
  -}
-pushToRemotes :: UTCTime -> Bool -> [Remote] -> Assistant Bool
-pushToRemotes now notifypushes remotes = do
+pushToRemotes :: Bool -> [Remote] -> Assistant Bool
+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 (pushAlert nonxmppremotes) go
+pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant Bool
+pushToRemotes' now notifypushes remotes = do
 	(g, branch, u) <- liftAnnex $ do
 		Annex.Branch.commit "update"
 		(,,)
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index a444a8530..8a695316e 100644
--- a/Assistant/Threads/Pusher.hs
+++ b/Assistant/Threads/Pusher.hs
@@ -17,8 +17,6 @@ import Assistant.Sync
 import Utility.ThreadScheduler
 import qualified Types.Remote as Remote
 
-import Data.Time.Clock
-
 {- This thread retries pushes that failed before. -}
 pushRetryThread :: NamedThread
 pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
@@ -27,9 +25,8 @@ 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) $ do
-			now <- liftIO $ getCurrentTime
-			pushToRemotes now True topush
+		void $ alertWhile (pushRetryAlert topush) $
+			pushToRemotes True topush
   where
 	halfhour = 1800
 
@@ -41,13 +38,9 @@ pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do
 	commits <- getCommits
 	-- Now see if now's a good time to push.
 	if shouldPush commits
-		then do
-			remotes <- filter (not . Remote.readonly) 
-				. syncGitRemotes <$> getDaemonStatus
-			unless (null remotes) $
-				void $ alertWhile (pushAlert remotes) $ do
-					now <- liftIO $ getCurrentTime
-					pushToRemotes now True remotes
+		then void $ pushToRemotes True
+			=<< filter (not . Remote.readonly) . syncGitRemotes
+				<$> getDaemonStatus
 		else do
 			debug ["delaying push of", show (length commits), "commits"]
 			refillCommits commits