prune old filler alerts

3 files changed, 43 insertions, 16 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 23a93b1c1..817a1be27 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -12,6 +12,7 @@ module Assistant.Alert where
 import Common.Annex
 import qualified Remote
 
+import qualified Data.Map as M
 import Yesod
 
 type Widget = forall sub master. GWidget sub master ()
@@ -20,6 +21,9 @@ type Widget = forall sub master. GWidget sub master ()
 data AlertClass = Success | Message | Activity | Warning | Error
 	deriving (Eq, Ord)
 
+data AlertPriority = Filler | Low | Medium | High | Pinned
+	deriving (Eq, Ord)
+
 {- An alert can be a simple message, or an arbitrary Yesod Widget. -}
 data AlertMessage = StringAlert String | WidgetAlert (Alert -> Widget)
 
@@ -37,8 +41,19 @@ type AlertId = Integer
 
 type AlertPair = (AlertId, Alert)
 
-data AlertPriority = Filler | Low | Medium | High | Pinned
-	deriving (Eq, Ord)
+type AlertMap = M.Map AlertId Alert
+
+{- This is as many alerts as it makes sense to display at a time.
+ - A display might be smaller ,or larger, the point is to not overwhelm the
+ - user with a ton of alerts. -}
+displayAlerts :: Int
+displayAlerts = 10
+
+{- This is not a hard maximum, but there's no point in keeping a great
+ - many filler alerts in an AlertMap, so when there's more than this many,
+ - they start being pruned, down toward displayAlerts. -}
+maxAlerts :: Int
+maxAlerts = displayAlerts * 2
 
 {- The desired order is the reverse of:
  -
@@ -57,9 +72,12 @@ compareAlertPairs
 		`thenOrd` compare aid bid
 			`thenOrd` compare aclass bclass
 
+sortAlertPairs :: [AlertPair] -> [AlertPair]
+sortAlertPairs = sortBy compareAlertPairs
+
 makeAlertFiller :: Bool -> Alert -> Alert
 makeAlertFiller success alert
-	| alertPriority alert == Filler = alert
+	| isFiller alert = alert
 	| otherwise = alert
 		{ alertClass = if c == Activity then c' else c
 		, alertPriority = Filler
@@ -79,11 +97,26 @@ makeAlertFiller success alert
 			maybe (finished s) (const s) h
 
 		finished s
-			| success = s ++ ": Succeeded"
+			| success = s ++ ": Ok"
 			| otherwise = s ++ ": Failed"
 
-sortAlertPairs :: [AlertPair] -> [AlertPair]
-sortAlertPairs = reverse . sortBy compareAlertPairs
+isFiller :: Alert -> Bool
+isFiller alert = alertPriority alert == Filler
+
+{- Converts a given alert into filler, manipulating it in the AlertMap.
+ -
+ - Old filler alerts are pruned once maxAlerts is reached.
+ -}
+convertToFiller :: AlertId -> Bool -> AlertMap -> AlertMap
+convertToFiller i success m
+	| bloat > 0 = M.fromList $ prune $ M.toList m'
+	| otherwise = m'
+	where
+		bloat = M.size m - maxAlerts
+		m' = M.adjust (\al -> makeAlertFiller success al) i m
+		prune l =
+			let (f, rest) = partition (\(_, al) -> isFiller al) l
+			in drop bloat f ++ rest
 
 baseActivityAlert :: Alert
 baseActivityAlert = Alert
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index 6d05c6152..77387deb8 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -50,8 +50,6 @@ data DaemonStatus = DaemonStatus
 
 type TransferMap = M.Map Transfer TransferInfo
 
-type AlertMap = M.Map AlertId Alert
-
 {- This TMVar is never left empty, so accessing it will never block. -}
 type DaemonStatusHandle = TMVar DaemonStatus
 
@@ -242,10 +240,5 @@ alertWhile dstatus alert a = do
 	let alert' = alert { alertClass = Activity }
 	i <- addAlert dstatus alert'
 	r <- bracket_ noop noop a
-	updateAlertMap dstatus $ makeold i (makeAlertFiller r)
+	updateAlertMap dstatus $ convertToFiller i 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
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index d26855910..5349ec2a4 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -204,11 +204,12 @@ sideBarDisplay noScript = do
 		{- Any yesod message appears as the first alert. -}
 		maybe noop rendermessage =<< lift getMessage
 	
-		{- Add newest 10 alerts to the sidebar. -}
+		{- Add newest alerts to the sidebar. -}
 		webapp <- lift getYesod
 		alertpairs <- M.toList . alertMap
 			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
-		mapM_ renderalert $ take 10 $ sortAlertPairs alertpairs
+		mapM_ renderalert $
+			take displayAlerts $ reverse $ sortAlertPairs alertpairs
 	ident <- lift newIdent
 	$(widgetFile "sidebar")