diff options
| -rw-r--r-- | Assistant/Alert.hs | 45 | ||||
| -rw-r--r-- | Assistant/DaemonStatus.hs | 9 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 5 |
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") |