make old activiy alerts stay visible

They're updated to show whether the activity succeeded or failed.

This adds several TODOs to the code to fix later.

6 files changed, 32 insertions, 20 deletions

diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
index 20862dac1..4baef1d11 100644
--- a/Assistant/Threads/MountWatcher.hs
+++ b/Assistant/Threads/MountWatcher.hs
@@ -165,7 +165,7 @@ handleMount st dstatus scanremotes mntent = do
 		branch <- runThreadState st $ Command.Sync.currentBranch
 		let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs
 		unless (null nonspecial) $
-			alertWhile dstatus (syncMountAlert dir nonspecial) $ do
+			void $ alertWhile dstatus (syncMountAlert dir nonspecial) $ do
 				debug thisThread ["syncing with", show nonspecial]
 				runThreadState st $ manualPull branch nonspecial
 				now <- getCurrentTime	
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index 1b0420b9b..0a0edf1d0 100644
--- a/Assistant/Threads/Pusher.hs
+++ b/Assistant/Threads/Pusher.hs
@@ -37,7 +37,7 @@ pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do
 			, "failed pushes"
 			]
 		now <- getCurrentTime
-		alertWhile dstatus (pushRetryAlert topush) $
+		void $ alertWhile dstatus (pushRetryAlert topush) $
 			pushToRemotes thisThread now st (Just pushmap) topush
 	where
 		halfhour = 1800
@@ -54,7 +54,7 @@ pushThread st dstatus commitchan pushmap = do
 		if shouldPush now commits
 			then do
 				remotes <- knownRemotes <$> getDaemonStatus dstatus
-				alertWhile dstatus (pushAlert remotes) $
+				void $ alertWhile dstatus (pushAlert remotes) $
 					pushToRemotes thisThread now st (Just pushmap) remotes
 			else do
 				debug thisThread
@@ -80,7 +80,7 @@ shouldPush _now commits
  -
  - Avoids running possibly long-duration commands in the Annex monad, so
  - as not to block other threads. -}
-pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO ()
+pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO Bool
 pushToRemotes threadname now st mpushmap remotes = do
 	(g, branch) <- runThreadState st $
 		(,) <$> fromRepo id <*> Command.Sync.currentBranch
@@ -92,6 +92,11 @@ pushToRemotes threadname now st mpushmap remotes = do
 				, show rs
 				]
 			Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
+			{- TODO git push exits nonzero if the remote
+			 - is already up-to-date. This code does not tell
+			 - the difference between the two. Could perhaps
+			 - be check the refs when it seemed to fail?
+			 - Note bewloe  -}
 			(succeeded, failed) <- inParallel (push g branch) rs
 			case mpushmap of
 				Nothing -> noop
@@ -104,8 +109,10 @@ pushToRemotes threadname now st mpushmap remotes = do
 					[ "failed to push to"
 					, show failed
 					]
-			unless (null failed || not shouldretry) $
-				retry branch g failed
+			if (null failed || not shouldretry)
+				{- TODO see above TODO item -}
+				then return True -- return $ null failed 
+				else retry branch g failed
 
 		makemap l = M.fromList $ zip l (repeat now)
 
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index cd5dc0644..a7c2189d8 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -31,7 +31,7 @@ sanityCheckerThread st dstatus transferqueue changechan = forever $ do
 
 	debug thisThread ["starting sanity check"]
 
-	alertWhile dstatus sanityCheckAlert go
+	void $ alertWhile dstatus sanityCheckAlert go
 	
 	debug thisThread ["sanity check complete"]
 	where
@@ -40,14 +40,18 @@ sanityCheckerThread st dstatus transferqueue changechan = forever $ do
 				{ sanityCheckRunning = True }
 
 			now <- getPOSIXTime -- before check started
-			catchIO (check st dstatus transferqueue changechan)
-				(runThreadState st . warning . show)
+			r <- catchIO (check st dstatus transferqueue changechan)
+				$ \e -> do
+					runThreadState st $ warning $ show e
+					return False
 
 			modifyDaemonStatus_ dstatus $ \s -> s
 				{ sanityCheckRunning = False
 				, lastSanityCheck = Just now
 				}
 
+			return r
+
 {- Only run one check per day, from the time of the last check. -}
 waitForNextCheck :: DaemonStatusHandle -> IO ()
 waitForNextCheck dstatus = do
@@ -67,7 +71,7 @@ oneDay = 24 * 60 * 60
 {- It's important to stay out of the Annex monad as much as possible while
  - running potentially expensive parts of this check, since remaining in it
  - will block the watcher. -}
-check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO () 
+check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO Bool
 check st dstatus transferqueue changechan = do
 	g <- runThreadState st $ fromRepo id
 	-- Find old unstaged symlinks, and add them to git.
@@ -80,6 +84,7 @@ check st dstatus transferqueue changechan = do
 				| isSymbolicLink s ->
 					addsymlink file ms
 			_ -> noop
+	return True
 	where
 		toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
 		slop = fromIntegral tenMinutes
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 1d91a65d4..2cba0b2a7 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -32,18 +32,19 @@ transferScannerThread st dstatus scanremotes transferqueue = do
 	runEvery (Seconds 2) $ do
 		r <- getScanRemote scanremotes
 		liftIO $ debug thisThread ["starting scan of", show r]
-		alertWhile dstatus (scanAlert r) $
+		void $ alertWhile dstatus (scanAlert r) $
 			scan st dstatus transferqueue r
 		liftIO $ debug thisThread ["finished scan of", show r]
 
 {- This is a naive scan through the git work tree.
  - 
  - The scan is blocked when the transfer queue gets too large. -}
-scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO ()
+scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO Bool
 scan st dstatus transferqueue r = do
 	g <- runThreadState st $ fromRepo id
 	files <- LsFiles.inRepo [] g
 	go files
+	return True
 	where
 		go [] = return ()
 		go (f:fs) = do
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index ddbd51655..bfeec7630 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -72,24 +72,23 @@ watchThread st dstatus transferqueue changechan = do
 			}
 
 {- Initial scartup scan. The action should return once the scan is complete. -}
-startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
+startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO ()
 startupScan st dstatus scanner = do
 	runThreadState st $ showAction "scanning"
-	r <- alertWhile dstatus startupScanAlert $ do
-		r <- scanner
-		modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True }
+	void $ alertWhile dstatus startupScanAlert $ do
+		void $ scanner
 
 		-- Notice any files that were deleted before
 		-- watching was started.
 		runThreadState st $ do
 			inRepo $ Git.Command.run "add" [Param "--update"]
 			showAction "started"
-		return r
+		
+		modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True }
+		return True
 	
 	void $ addAlert dstatus runningAlert
 
-	return r
-
 ignored :: FilePath -> Bool
 ignored = ig . takeFileName
 	where
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 7ad40c307..d26855910 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -232,7 +232,7 @@ sideBarDisplay noScript = do
 			(alertHeader alert)
 			$ case alertMessage alert of
 				StringAlert s -> [whamlet|#{s}|]
-				WidgetAlert w -> w
+				WidgetAlert w -> w alert
 
 		rendermessage msg = addalert "yesodmessage" True False
 			"alert-info" Nothing [whamlet|#{msg}|]