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.

Assistant/Alert.hs

@@ -20,8 +20,8 @@ type Widget = forall sub master. GWidget sub master ()
 data AlertClass = Success | Message | Activity | Warning | Error
 	deriving (Eq, Ord)
 
-{- An alert can be a simple message, or an arbitrary Yesod Widget -}
+{- An alert can be a simple message, or an arbitrary Yesod Widget. -}
-data AlertMessage = StringAlert String | WidgetAlert Widget
+data AlertMessage = StringAlert String | WidgetAlert (Alert -> Widget)
 
 data Alert = Alert
 	{ alertClass :: AlertClass
@@ -37,7 +37,7 @@ type AlertId = Integer
 
 type AlertPair = (AlertId, Alert)
 
-data AlertPriority = Low | Medium | High | Pinned
+data AlertPriority = Filler | Low | Medium | High | Pinned
 	deriving (Eq, Ord)
 
 {- The desired order is the reverse of:
@@ -45,7 +45,8 @@ data AlertPriority = Low | Medium | High | Pinned
  - - Pinned alerts
  - - High priority alerts, newest first
  - - Medium priority Activity, newest first (mostly used for Activity)
- - - Low priority alwerts, newest first
+ - - Low priority alerts, newest first
+ - - Filler priorty alerts, newest first
  - - Ties are broken by the AlertClass, with Errors etc coming first.
  -}
 compareAlertPairs :: AlertPair -> AlertPair -> Ordering
@@ -56,6 +57,31 @@ compareAlertPairs
 		`thenOrd` compare aid bid
 			`thenOrd` compare aclass bclass
 
+makeAlertFiller :: Bool -> Alert -> Alert
+makeAlertFiller success alert
+	| alertPriority alert == Filler = alert
+	| otherwise = alert
+		{ alertClass = if c == Activity then c' else c
+		, alertPriority = Filler
+		, alertHeader = finished <$> h
+		, alertMessage = massage m
+		}
+	where
+		h = alertHeader alert
+		m = alertMessage alert
+		c = alertClass alert
+		c'
+			| success = Success
+			| otherwise = Error
+
+		massage (WidgetAlert w) = WidgetAlert w -- renders old on its own
+		massage (StringAlert s) = StringAlert $
+			maybe (finished s) (const s) h
+
+		finished s
+			| success = s ++ ": Succeeded"
+			| otherwise = s ++ ": Failed"
+
 sortAlertPairs :: [AlertPair] -> [AlertPair]
 sortAlertPairs = reverse . sortBy compareAlertPairs
 

Assistant/DaemonStatus.hs

@@ -223,12 +223,29 @@ addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus
 				m = M.insertWith' const i alert (alertMap s)
 
 removeAlert :: DaemonStatusHandle -> AlertId -> IO ()
-removeAlert dstatus i = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go
+removeAlert dstatus i = updateAlert dstatus i (const Nothing)
-	where
-		go s = s { alertMap = M.delete i (alertMap s) }
 
-{- Displays an alert while performing an activity, then removes it. -}
+updateAlert :: DaemonStatusHandle -> AlertId -> (Alert -> Maybe Alert) -> IO ()
-alertWhile :: DaemonStatusHandle -> Alert -> IO a -> IO a
+updateAlert dstatus i a = updateAlertMap dstatus $ \m -> M.update a i m
+
+updateAlertMap :: DaemonStatusHandle -> (AlertMap -> AlertMap) -> IO ()
+updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go
+	where
+		go s = s { alertMap = a (alertMap s) }
+
+{- Displays an alert while performing an activity.
+ -
+ - The alert is left visible afterwards, as filler.
+ - Old filler is pruned, to prevent the map growing too large. -}
+alertWhile :: DaemonStatusHandle -> Alert -> IO Bool -> IO Bool
 alertWhile dstatus alert a = do
 	let alert' = alert { alertClass = Activity }
-	bracket (addAlert dstatus alert') (removeAlert dstatus) (const a)
+	i <- addAlert dstatus alert'
+	r <- bracket_ noop noop a
+	updateAlertMap dstatus $ makeold i (makeAlertFiller r)
+	return r
+	where
+		-- TODO prune old filler
+		makeold i filler m
+			| M.size m < 20 = M.adjust filler i m
+			| otherwise = M.adjust filler i m

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	

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) $
+			if (null failed || not shouldretry)
-				retry branch g failed
+				{- TODO see above TODO item -}
+				then return True -- return $ null failed 
+				else retry branch g failed
 
 		makemap l = M.fromList $ zip l (repeat now)
 

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)
+			r <- catchIO (check st dstatus transferqueue changechan)
-				(runThreadState st . warning . show)
+				$ \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

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

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
+	void $ alertWhile dstatus startupScanAlert $ do
-		r <- scanner
+		void $ scanner
-		modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True }
 
 		-- 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

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