diff options
| -rw-r--r-- | Assistant/Alert.hs | 41 | ||||
| -rw-r--r-- | Assistant/DaemonStatus.hs | 1 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 19 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 8 | ||||
| -rw-r--r-- | Utility/Misc.hs | 7 | ||||
| -rw-r--r-- | templates/transfers.hamlet | 1 |
6 files changed, 61 insertions, 16 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 6b0804fd8..648ea5854 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -17,8 +17,8 @@ import Yesod type Widget = forall sub master. GWidget sub master () {- Different classes of alerts are displayed differently. -} -data AlertClass = Activity | Warning | Error | Success | Message - deriving (Eq) +data AlertClass = Success | Message | Activity | Warning | Error + deriving (Eq, Ord) {- An alert can be a simple message, or an arbitrary Yesod Widget -} data AlertMessage = StringAlert String | WidgetAlert Widget @@ -28,19 +28,53 @@ data Alert = Alert , alertHeader :: Maybe String , alertMessage :: AlertMessage , alertBlockDisplay :: Bool + , alertPriority :: AlertPriority } +{- Higher AlertId indicates a more recent alert. -} +type AlertId = Integer + +type AlertPair = (AlertId, Alert) + +data AlertPriority = Low | Medium | High + deriving (Eq, Ord) + +{- The desired order is the reverse of: + - + - - High priority alerts, newest first + - - Medium priority Activity, newest first (mostly used for Activity) + - - Low priority alwerts, newest first + - - Ties are broken by the AlertClass, with Errors etc coming first. + -} +compareAlertPairs :: AlertPair -> AlertPair -> Ordering +compareAlertPairs + (aid, Alert {alertClass = aclass, alertPriority = aprio}) + (bid, Alert {alertClass = bclass, alertPriority = bprio}) + = compare aprio bprio + `thenOrd` compare aid bid + `thenOrd` compare aclass bclass + +sortAlertPairs :: [AlertPair] -> [AlertPair] +sortAlertPairs = reverse . sortBy compareAlertPairs + activityAlert :: Maybe String -> String -> Alert activityAlert header message = Alert { alertClass = Activity , alertHeader = header , alertMessage = StringAlert message , alertBlockDisplay = False + , alertPriority = Medium } startupScanAlert :: Alert startupScanAlert = activityAlert Nothing "Performing startup scan" +runningAlert :: Alert +runningAlert = (activityAlert Nothing "Running") + { alertClass = Success + , alertPriority = High -- pin above the other activity alerts + } + pushAlert :: [Remote] -> Alert pushAlert rs = activityAlert Nothing $ "Syncing with " ++ unwords (map Remote.name rs) @@ -59,6 +93,7 @@ syncMountAlert dir rs = Alert , " -- let's get it in sync!" ] , alertBlockDisplay = True + , alertPriority = Low } scanAlert :: Remote -> Alert @@ -69,6 +104,7 @@ scanAlert r = Alert [ "Ensuring that ", Remote.name r , "is fully in sync." ] , alertBlockDisplay = True + , alertPriority = Low } sanityCheckAlert :: Alert @@ -85,4 +121,5 @@ sanityCheckFixAlert msg = Alert , "If these problems persist, consider filing a bug report." ] , alertBlockDisplay = True + , alertPriority = High } diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 62cf2ea2a..f1b3bdb9f 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -51,7 +51,6 @@ data DaemonStatus = DaemonStatus type TransferMap = M.Map Transfer TransferInfo type AlertMap = M.Map AlertId Alert -type AlertId = Integer {- This TMVar is never left empty, so accessing it will never block. -} type DaemonStatusHandle = TMVar DaemonStatus diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 1c8d122d5..ddbd51655 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -75,13 +75,18 @@ watchThread st dstatus transferqueue changechan = do startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a startupScan st dstatus scanner = do runThreadState st $ showAction "scanning" - r <- alertWhile dstatus startupScanAlert 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" + r <- alertWhile dstatus startupScanAlert $ do + r <- 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 + + void $ addAlert dstatus runningAlert return r diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 3d42db812..4d37a941a 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -34,7 +34,6 @@ import Network.Socket (PortNumber) import Text.Blaze.Renderer.String import Data.Text (Text, pack, unpack) import qualified Data.Map as M -import Data.Function thisThread :: String thisThread = "WebApp" @@ -158,10 +157,9 @@ sideBarDisplay noScript = do {- Add newest 10 alerts to the sidebar. -} webapp <- lift getYesod - alerts <- M.toList . alertMap + alertpairs <- M.toList . alertMap <$> liftIO (getDaemonStatus $ daemonStatus webapp) - mapM_ renderalert $ - take 10 $ reverse $ sortBy (compare `on` fst) alerts + mapM_ renderalert $ take 10 $ sortAlertPairs alertpairs ident <- lift newIdent $(widgetFile "sidebar") @@ -180,7 +178,7 @@ sideBarDisplay noScript = do renderalert (alertid, alert) = addalert (show alertid) -- Activity alerts auto-close - (not noScript && alertClass alert /= Activity) + (alertClass alert /= Activity) (alertBlockDisplay alert) (bootstrapclass $ alertClass alert) (alertHeader alert) diff --git a/Utility/Misc.hs b/Utility/Misc.hs index e11586467..77ebb4f3d 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -45,3 +45,10 @@ segment p l = map reverse $ go [] [] l go c r (i:is) | p i = go [] (c:r) is | otherwise = go (i:c) r is + +{- Given two orderings, returns the second if the first is EQ and returns + - the first otherwise. -} +thenOrd :: Ordering -> Ordering -> Ordering +thenOrd EQ x = x +thenOrd x _ = x +{-# INLINE thenOrd #-} diff --git a/templates/transfers.hamlet b/templates/transfers.hamlet index bc69d7f87..e79885fb5 100644 --- a/templates/transfers.hamlet +++ b/templates/transfers.hamlet @@ -1,6 +1,5 @@ <div .span9 ##{ident}> $if null transfers - <h2>No current transfers $else <h2>Transfers $forall (transfer, info) <- transfers |