add more alerts

Nearly all long-running actions now display an alert.

3 files changed, 53 insertions, 29 deletions

diff --git a/Assistant.hs b/Assistant.hs
index 1f41a9398..22a87fe8c 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -146,7 +146,7 @@ startDaemon assistant foreground webappwaiter
 			mapM_ forkIO
 				[ commitThread st changechan commitchan transferqueue dstatus
 				, pushThread st dstatus commitchan pushmap
-				, pushRetryThread st pushmap
+				, pushRetryThread st dstatus pushmap
 				, mergeThread st
 				, transferWatcherThread st dstatus
 				, transfererThread st dstatus transferqueue transferslots
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index 3762c4836..27e95a734 100644
--- a/Assistant/Threads/Pusher.hs
+++ b/Assistant/Threads/Pusher.hs
@@ -10,12 +10,14 @@ module Assistant.Threads.Pusher where
 import Assistant.Common
 import Assistant.Commits
 import Assistant.Pushes
-import Assistant.DaemonStatus
+import Assistant.Alert
 import Assistant.ThreadedMonad
 import Assistant.Threads.Merger
+import Assistant.DaemonStatus
 import qualified Command.Sync
 import Utility.ThreadScheduler
 import Utility.Parallel
+import qualified Remote
 
 import Data.Time.Clock
 import qualified Data.Map as M
@@ -24,8 +26,8 @@ thisThread :: ThreadName
 thisThread = "Pusher"
 
 {- This thread retries pushes that failed before. -}
-pushRetryThread :: ThreadState -> FailedPushMap -> IO ()
-pushRetryThread st pushmap = runEvery (Seconds halfhour) $ do
+pushRetryThread :: ThreadState -> DaemonStatusHandle -> FailedPushMap -> IO ()
+pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do
 	-- We already waited half an hour, now wait until there are failed
 	-- pushes to retry.
 	topush <- getFailedPushesBefore pushmap (fromIntegral halfhour)
@@ -36,13 +38,16 @@ pushRetryThread st pushmap = runEvery (Seconds halfhour) $ do
 			, "failed pushes"
 			]
 		now <- getCurrentTime
-		pushToRemotes thisThread now st (Just pushmap) topush
+		alertWhile dstatus (alert topush) $
+			pushToRemotes thisThread now st (Just pushmap) topush
 	where
 		halfhour = 1800
+		alert rs = activityAlert (Just "Retrying sync") $
+			"with " ++ unwords (map Remote.name rs) ++ ", which failed earlier."
 
 {- This thread pushes git commits out to remotes soon after they are made. -}
 pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> IO ()
-pushThread st daemonstatus commitchan pushmap = do
+pushThread st dstatus commitchan pushmap = do
 	runEvery (Seconds 2) $ do
 		-- We already waited two seconds as a simple rate limiter.
 		-- Next, wait until at least one commit has been made
@@ -51,8 +56,9 @@ pushThread st daemonstatus commitchan pushmap = do
 		now <- getCurrentTime
 		if shouldPush now commits
 			then do
-				remotes <- knownRemotes <$> getDaemonStatus daemonstatus
-				pushToRemotes thisThread now st (Just pushmap) remotes
+				remotes <- knownRemotes <$> getDaemonStatus dstatus
+				alertWhile dstatus (syncalert remotes) $
+					pushToRemotes thisThread now st (Just pushmap) remotes
 			else do
 				debug thisThread
 					[ "delaying push of"
@@ -60,6 +66,9 @@ pushThread st daemonstatus commitchan pushmap = do
 					, "commits"
 					]
 				refillCommits commitchan commits
+	where
+		syncalert rs = activityAlert Nothing $
+			"Syncing with " ++ unwords (map Remote.name rs)
 
 {- Decide if now is a good time to push to remotes.
  -
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 5e27246a0..69610c2a7 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -13,6 +13,7 @@ import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.ThreadedMonad
 import Assistant.Changes
+import Assistant.Alert
 import Assistant.TransferQueue
 import qualified Git.LsFiles
 import Utility.ThreadScheduler
@@ -25,29 +26,34 @@ thisThread = "SanityChecker"
 
 {- This thread wakes up occasionally to make sure the tree is in good shape. -}
 sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
-sanityCheckerThread st status transferqueue changechan = forever $ do
-	waitForNextCheck status
+sanityCheckerThread st dstatus transferqueue changechan = forever $ do
+	waitForNextCheck dstatus
 
 	debug thisThread ["starting sanity check"]
 
-	modifyDaemonStatus_ status $ \s -> s
-		{ sanityCheckRunning = True }
-
-	now <- getPOSIXTime -- before check started
-	catchIO (check st status transferqueue changechan)
-		(runThreadState st . warning . show)
-
-	modifyDaemonStatus_ status $ \s -> s
-		{ sanityCheckRunning = False
-		, lastSanityCheck = Just now
-		}
+	alertWhile dstatus alert go
 	
 	debug thisThread ["sanity check complete"]
+	where
+		go = do
+			modifyDaemonStatus_ dstatus $ \s -> s
+				{ sanityCheckRunning = True }
+
+			now <- getPOSIXTime -- before check started
+			catchIO (check st dstatus transferqueue changechan)
+				(runThreadState st . warning . show)
+
+			modifyDaemonStatus_ dstatus $ \s -> s
+				{ sanityCheckRunning = False
+				, lastSanityCheck = Just now
+				}
+		alert = activityAlert (Just "Running daily sanity check")
+			"to make sure I've not missed anything."
 
 {- Only run one check per day, from the time of the last check. -}
 waitForNextCheck :: DaemonStatusHandle -> IO ()
-waitForNextCheck status = do
-	v <- lastSanityCheck <$> getDaemonStatus status
+waitForNextCheck dstatus = do
+	v <- lastSanityCheck <$> getDaemonStatus dstatus
 	now <- getPOSIXTime
 	threadDelaySeconds $ Seconds $ calcdelay now v
 	where
@@ -64,10 +70,8 @@ oneDay = 24 * 60 * 60
  - running potentially expensive parts of this check, since remaining in it
  - will block the watcher. -}
 check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO () 
-check st status transferqueue changechan = do
-	g <- runThreadState st $ do
-		showSideAction "Running daily check"
-		fromRepo id
+check st dstatus transferqueue changechan = do
+	g <- runThreadState st $ fromRepo id
 	-- Find old unstaged symlinks, and add them to git.
 	unstaged <- Git.LsFiles.notInRepo False ["."] g
 	now <- getPOSIXTime
@@ -81,9 +85,20 @@ check st status transferqueue changechan = do
 	where
 		toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
 		slop = fromIntegral tenMinutes
-		insanity m = runThreadState st $ warning m
+		insanity msg = do
+			runThreadState st $ warning msg
+			void $ addAlert dstatus $ Alert
+			        { alertClass = Warning
+			        , alertHeader = Just "Fixed a problem"
+			        , alertMessage = StringAlert $ unwords
+					[ "The daily sanity check found and fixed a problem:"
+					, msg
+					, "If these problems persist, consider filing a bug report."
+					]
+			        , alertBlockDisplay = True
+		        }
 		addsymlink file s = do
 			insanity $ "found unstaged symlink: " ++ file
-			Watcher.runHandler thisThread st status
+			Watcher.runHandler thisThread st dstatus
 				transferqueue changechan
 				Watcher.onAddSymlink file s