{- git-annex assistant alerts - - Copyright 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} module Assistant.Alert where import Common.Annex import qualified Remote import Utility.Tense import Logs.Transfer import qualified Data.Text as T import Data.Text (Text) import qualified Data.Map as M import Data.String import Yesod {- Different classes of alerts are displayed differently. -} data AlertClass = Success | Message | Activity | Warning | Error deriving (Eq, Ord) data AlertPriority = Filler | Low | Medium | High | Pinned deriving (Eq, Ord) {- An alert can have an name, which is used to combine it with other similar - alerts. -} data AlertName = FileAlert TenseChunk | SanityCheckFixAlert | WarningAlert String | PairAlert String | XMPPNeededAlert deriving (Eq) {- The first alert is the new alert, the second is an old alert. - Should return a modified version of the old alert. -} type AlertCombiner = Alert -> Alert -> Maybe Alert data Alert = Alert { alertClass :: AlertClass , alertHeader :: Maybe TenseText , alertMessageRender :: [TenseChunk] -> TenseText , alertData :: [TenseChunk] , alertBlockDisplay :: Bool , alertClosable :: Bool , alertPriority :: AlertPriority , alertIcon :: Maybe AlertIcon , alertCombiner :: Maybe AlertCombiner , alertName :: Maybe AlertName , alertButton :: Maybe AlertButton } data AlertIcon = ActivityIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud htmlIcon :: AlertIcon -> GWidget sub master () htmlIcon ActivityIcon = bootStrapIcon "refresh" htmlIcon InfoIcon = bootStrapIcon "info-sign" htmlIcon SuccessIcon = bootStrapIcon "ok" htmlIcon ErrorIcon = bootStrapIcon "exclamation-sign" -- utf-8 umbrella (utf-8 cloud looks too stormy) htmlIcon TheCloud = [whamlet|☂|] bootStrapIcon :: Text -> GWidget sub master () bootStrapIcon name = [whamlet||] {- When clicked, a button always redirects to a URL - It may also run an IO action in the background, which is useful - to make the button close or otherwise change the alert. -} data AlertButton = AlertButton { buttonLabel :: Text , buttonUrl :: Text , buttonAction :: Maybe (AlertId -> IO ()) } type AlertPair = (AlertId, Alert) type AlertMap = M.Map AlertId Alert {- Higher AlertId indicates a more recent alert. -} newtype AlertId = AlertId Integer deriving (Read, Show, Eq, Ord) firstAlertId :: AlertId firstAlertId = AlertId 0 nextAlertId :: AlertId -> AlertId nextAlertId (AlertId i) = AlertId $ succ i {- 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 = 6 {- 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: - - - Pinned alerts - - High priority alerts, newest first - - Medium priority Activity, newest first (mostly used for Activity) - - 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 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 = sortBy compareAlertPairs {- Renders an alert's header for display, if it has one. -} renderAlertHeader :: Alert -> Maybe Text renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert {- Renders an alert's message for display. -} renderAlertMessage :: Alert -> Text renderAlertMessage alert = renderTense (alertTense alert) $ (alertMessageRender alert) (alertData alert) alertTense :: Alert -> Tense alertTense alert | alertClass alert == Activity = Present | otherwise = Past {- Checks if two alerts display the same. -} effectivelySameAlert :: Alert -> Alert -> Bool effectivelySameAlert x y = all id [ alertClass x == alertClass y , alertHeader x == alertHeader y , alertData x == alertData y , alertBlockDisplay x == alertBlockDisplay y , alertClosable x == alertClosable y , alertPriority x == alertPriority y ] makeAlertFiller :: Bool -> Alert -> Alert makeAlertFiller success alert | isFiller alert = alert | otherwise = alert { alertClass = if c == Activity then c' else c , alertPriority = Filler , alertClosable = True , alertButton = Nothing , alertIcon = Just $ if success then SuccessIcon else ErrorIcon } where c = alertClass alert c' | success = Success | otherwise = Error isFiller :: Alert -> Bool isFiller alert = alertPriority alert == Filler {- Updates the Alertmap, adding or updating an alert. - - Any old filler that looks the same as the alert is removed. - - Or, if the alert has an alertCombiner that combines it with - an old alert, the old alert is replaced with the result, and the - alert is removed. - - Old filler alerts are pruned once maxAlerts is reached. -} mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al) where pruneSame k al' = k == i || not (effectivelySameAlert al al') pruneBloat m' | bloat > 0 = M.fromList $ pruneold $ M.toList m' | otherwise = m' where bloat = M.size m' - maxAlerts pruneold l = let (f, rest) = partition (\(_, a) -> isFiller a) l in drop bloat f ++ rest updatePrune = pruneBloat $ M.filterWithKey pruneSame $ M.insertWith' const i al m updateCombine combiner = let combined = M.mapMaybe (combiner al) m in if M.null combined then updatePrune else M.delete i $ M.union combined m baseActivityAlert :: Alert baseActivityAlert = Alert { alertClass = Activity , alertHeader = Nothing , alertMessageRender = tenseWords , alertData = [] , alertBlockDisplay = False , alertClosable = False , alertPriority = Medium , alertIcon = Just ActivityIcon , alertCombiner = Nothing , alertName = Nothing , alertButton = Nothing } warningAlert :: String -> String -> Alert warningAlert name msg = Alert { alertClass = Warning , alertHeader = Just $ tenseWords ["warning"] , alertMessageRender = tenseWords , alertData = [UnTensed $ T.pack msg] , alertBlockDisplay = True , alertClosable = True , alertPriority = High , alertIcon = Just ErrorIcon , alertCombiner = Just $ dataCombiner (++) , alertName = Just $ WarningAlert name , alertButton = Nothing } activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert activityAlert header dat = baseActivityAlert { alertHeader = header , alertData = dat } startupScanAlert :: Alert startupScanAlert = activityAlert Nothing [Tensed "Performing" "Performed", "startup scan"] commitAlert :: Alert commitAlert = activityAlert Nothing [Tensed "Committing" "Committed", "changes to git"] showRemotes :: [Remote] -> TenseChunk showRemotes = UnTensed . T.unwords . map (T.pack . Remote.name) pushAlert :: [Remote] -> Alert pushAlert rs = activityAlert Nothing [Tensed "Syncing" "Synced", "with", showRemotes rs] pushRetryAlert :: [Remote] -> Alert pushRetryAlert rs = activityAlert (Just $ tenseWords [Tensed "Retrying" "Retried", "sync"]) ["with", showRemotes rs] syncAlert :: [Remote] -> Alert syncAlert rs = baseActivityAlert { alertHeader = Just $ tenseWords [Tensed "Syncing" "Synced", "with", showRemotes rs] , alertData = [] , alertPriority = Low } scanAlert :: [Remote] -> Alert scanAlert rs = baseActivityAlert { alertHeader = Just $ tenseWords [Tensed "Scanning" "Scanned", showRemotes rs] , alertBlockDisplay = True , alertPriority = Low } sanityCheckAlert :: Alert sanityCheckAlert = activityAlert (Just $ tenseWords [Tensed "Running" "Ran", "daily sanity check"]) ["to make sure everything is ok."] sanityCheckFixAlert :: String -> Alert sanityCheckFixAlert msg = Alert { alertClass = Warning , alertHeader = Just $ tenseWords ["Fixed a problem"] , alertMessageRender = render , alertData = [UnTensed $ T.pack msg] , alertBlockDisplay = True , alertPriority = High , alertClosable = True , alertIcon = Just ErrorIcon , alertName = Just SanityCheckFixAlert , alertCombiner = Just $ dataCombiner (++) , alertButton = Nothing } where render dta = tenseWords $ alerthead : dta ++ [alertfoot] alerthead = "The daily sanity check found and fixed a problem:" alertfoot = "If these problems persist, consider filing a bug report." pairingAlert :: AlertButton -> Alert pairingAlert button = baseActivityAlert { alertData = [ UnTensed "Pairing in progress" ] , alertPriority = High , alertButton = Just button } pairRequestReceivedAlert :: String -> AlertButton -> Alert pairRequestReceivedAlert repo button = Alert { alertClass = Message , alertHeader = Nothing , alertMessageRender = tenseWords , alertData = [UnTensed $ T.pack $ repo ++ " is sending a pair request."] , alertBlockDisplay = False , alertPriority = High , alertClosable = True , alertIcon = Just InfoIcon , alertName = Just $ PairAlert repo , alertCombiner = Just $ dataCombiner $ \_old new -> new , alertButton = Just button } pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert pairRequestAcknowledgedAlert repo button = baseActivityAlert { alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"] , alertPriority = High , alertCombiner = Just $ dataCombiner $ \_old new -> new , alertButton = button } xmppNeededAlert :: AlertButton -> Alert xmppNeededAlert button = Alert { alertHeader = Just "Keep your repositories in sync across the cloud, or share with friends." , alertIcon = Just TheCloud , alertPriority = High , alertButton = Just button , alertClosable = True , alertClass = Message , alertMessageRender = tenseWords , alertBlockDisplay = True , alertName = Just $ XMPPNeededAlert , alertCombiner = Just $ dataCombiner $ \_old new -> new , alertData = [] } fileAlert :: TenseChunk -> FilePath -> Alert fileAlert msg file = (activityAlert Nothing [f]) { alertName = Just $ FileAlert msg , alertMessageRender = render , alertCombiner = Just $ dataCombiner combiner } where f = fromString $ shortFile $ takeFileName file render fs = tenseWords $ msg : fs combiner new old = take 10 $ new ++ old addFileAlert :: FilePath -> Alert addFileAlert = fileAlert (Tensed "Adding" "Added") {- This is only used as a success alert after a transfer, not during it. -} transferFileAlert :: Direction -> Bool -> FilePath -> Alert transferFileAlert direction True | direction == Upload = fileAlert "Uploaded" | otherwise = fileAlert "Downloaded" transferFileAlert direction False | direction == Upload = fileAlert "Upload failed" | otherwise = fileAlert "Download failed" dataCombiner :: ([TenseChunk] -> [TenseChunk] -> [TenseChunk]) -> AlertCombiner dataCombiner combiner new old | alertClass new /= alertClass old = Nothing | alertName new == alertName old = Just $! old { alertData = alertData new `combiner` alertData old } | otherwise = Nothing shortFile :: FilePath -> String shortFile f | len < maxlen = f | otherwise = take half f ++ ".." ++ drop (len - half) f where len = length f maxlen = 20 half = (maxlen - 2) `div` 2