diff options
author | Joey Hess <joey@kitenet.net> | 2013-04-04 01:48:26 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2013-04-04 01:48:26 -0400 |
commit | 0d021ce388369f3f683f9c9c8d13b5c983b12ca3 (patch) | |
tree | dab67313491f4680ef0454f6396f6007d750511a /Assistant | |
parent | 8fb369aa5667f95d46b24f26b06636559155402b (diff) |
refactor alert button creation code
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/Alert.hs | 203 | ||||
-rw-r--r-- | Assistant/Alert/Utility.hs | 130 | ||||
-rw-r--r-- | Assistant/Common.hs | 1 | ||||
-rw-r--r-- | Assistant/DaemonStatus.hs | 2 | ||||
-rw-r--r-- | Assistant/DeleteRemote.hs | 25 | ||||
-rw-r--r-- | Assistant/NamedThread.hs | 20 | ||||
-rw-r--r-- | Assistant/Sync.hs | 1 | ||||
-rw-r--r-- | Assistant/Threads/PairListener.hs | 12 | ||||
-rw-r--r-- | Assistant/Threads/Transferrer.hs | 1 | ||||
-rw-r--r-- | Assistant/Threads/XMPPClient.hs | 18 | ||||
-rw-r--r-- | Assistant/Types/Alert.hs | 74 | ||||
-rw-r--r-- | Assistant/Types/DaemonStatus.hs | 2 |
12 files changed, 263 insertions, 226 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 81dc362e4..c818dbf32 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -1,198 +1,45 @@ {- git-annex assistant alerts - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, CPP #-} module Assistant.Alert where import Common.Annex +import Assistant.Types.Alert +import Assistant.Alert.Utility 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 qualified Data.Text as T -{- 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 - | RemoteRemovalAlert String - | CloudRepoNeededAlert - | SyncAlert - 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 - -{- 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) - -showAlert :: Alert -> String -showAlert alert = T.unpack $ T.unwords $ catMaybes - [ renderAlertHeader alert - , Just $ renderAlertMessage 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 +#ifdef WITH_WEBAPP +import Assistant.Monad +import Assistant.DaemonStatus +import Assistant.WebApp.Types +import Assistant.WebApp +import Yesod.Core +#endif + +{- Makes a button for an alert that opens a Route. The button will + - close the alert it's attached to when clicked. -} +#ifdef WITH_WEBAPP +mkAlertButton :: T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton +mkAlertButton label urlrenderer route = do + close <- asIO1 removeAlert + url <- liftIO $ renderUrl urlrenderer route [] + return $ AlertButton + { buttonLabel = label + , buttonUrl = url + , buttonAction = Just close } - 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 +#endif baseActivityAlert :: Alert baseActivityAlert = Alert diff --git a/Assistant/Alert/Utility.hs b/Assistant/Alert/Utility.hs new file mode 100644 index 000000000..4757c4498 --- /dev/null +++ b/Assistant/Alert/Utility.hs @@ -0,0 +1,130 @@ +{- git-annex assistant alert utilities + - + - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Alert.Utility where + +import Common.Annex +import Assistant.Types.Alert +import Utility.Tense + +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Map as M + +{- 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 + +type AlertPair = (AlertId, Alert) + +{- 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) + +showAlert :: Alert -> String +showAlert alert = T.unpack $ T.unwords $ catMaybes + [ renderAlertHeader alert + , Just $ renderAlertMessage 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 diff --git a/Assistant/Common.hs b/Assistant/Common.hs index 0be536250..f9719422d 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -11,3 +11,4 @@ import Common.Annex as X import Assistant.Monad as X import Assistant.Types.DaemonStatus as X import Assistant.Types.NamedThread as X +import Assistant.Types.Alert as X diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index b6c9d0a67..c966fc93a 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -8,7 +8,7 @@ module Assistant.DaemonStatus where import Assistant.Common -import Assistant.Alert +import Assistant.Alert.Utility import Utility.TempFile import Assistant.Types.NetMessager import Utility.NotificationBroadcaster diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs index 65cd056f2..cae377e53 100644 --- a/Assistant/DeleteRemote.hs +++ b/Assistant/DeleteRemote.hs @@ -10,14 +10,10 @@ module Assistant.DeleteRemote where import Assistant.Common -#ifdef WITH_WEBAPP -import Assistant.WebApp.Types -import Assistant.WebApp -#endif +import Assistant.Types.UrlRenderer import Assistant.TransferQueue import Logs.Transfer import Logs.Location -import Assistant.Alert import Assistant.DaemonStatus import qualified Remote import Remote.List @@ -25,7 +21,12 @@ import qualified Git.Command import Logs.Trust import qualified Annex +#ifdef WITH_WEBAPP +import Assistant.WebApp.Types +import Assistant.WebApp +import Assistant.Alert import qualified Data.Text as T +#endif {- Removes a remote (but leave the repository as-is), and returns the old - Remote data. -} @@ -82,16 +83,12 @@ removableRemote urlrenderer uuid = do - Without the webapp, just do the removal now. -} finishRemovingRemote :: UrlRenderer -> UUID -> Assistant () -finishRemovingRemote urlrenderer uuid = do #ifdef WITH_WEBAPP +finishRemovingRemote urlrenderer uuid = do desc <- liftAnnex $ Remote.prettyUUID uuid - url <- liftIO $ renderUrl urlrenderer (FinishDeleteRepositoryR uuid) [] - close <- asIO1 removeAlert - void $ addAlert $ remoteRemovalAlert desc $ AlertButton - { buttonLabel = T.pack "Finish deletion process" - , buttonUrl = url - , buttonAction = Just close - } + button <- mkAlertButton (T.pack "Finish deletion process") urlrenderer $ + FinishDeleteRepositoryR uuid + void $ addAlert $ remoteRemovalAlert desc button #else - +finishRemovingRemote _ uuid = void $ removeRemote uuid #endif diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index 1d291ba74..edebe830f 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -23,8 +23,8 @@ import qualified Data.Map as M import qualified Control.Exception as E #ifdef WITH_WEBAPP -import Assistant.WebApp import Assistant.WebApp.Types +import Assistant.Types.Alert import Assistant.Alert import qualified Data.Text as T #endif @@ -65,17 +65,13 @@ startNamedThread urlrenderer namedthread@(NamedThread name a) = do ] hPutStrLn stderr msg #ifdef WITH_WEBAPP - button <- runAssistant d $ do - close <- asIO1 removeAlert - url <- liftIO $ renderUrl urlrenderer (RestartThreadR name) [] - return $ Just $ AlertButton - { buttonLabel = T.pack "Restart Thread" - , buttonUrl = url - , buttonAction = Just close - } - runAssistant d $ void $ - addAlert $ (warningAlert (fromThreadName name) msg) - { alertButton = button } + button <- runAssistant d $ mkAlertButton + (T.pack "Restart Thread") + urlrenderer + (RestartThreadR name) + runAssistant d $ void $ addAlert $ + (warningAlert (fromThreadName name) msg) + { alertButton = Just button } #endif namedThreadId :: NamedThread -> Assistant (Maybe ThreadId) diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index b431a8439..50e8e7321 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -12,6 +12,7 @@ import Assistant.Pushes import Assistant.NetMessager import Assistant.Types.NetMessager import Assistant.Alert +import Assistant.Alert.Utility import Assistant.DaemonStatus import Assistant.ScanRemotes import qualified Command.Sync diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 4459ee13c..cb9a94eff 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -11,7 +11,7 @@ import Assistant.Common import Assistant.Pairing import Assistant.Pairing.Network import Assistant.Pairing.MakeRemote -import Assistant.WebApp (UrlRenderer, renderUrl) +import Assistant.WebApp (UrlRenderer) import Assistant.WebApp.Types import Assistant.Alert import Assistant.DaemonStatus @@ -101,14 +101,8 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant () pairReqReceived True _ _ = noop -- ignore our own PairReq pairReqReceived False urlrenderer msg = do - url <- liftIO $ renderUrl urlrenderer (FinishLocalPairR msg) [] - closealert <- asIO1 removeAlert - void $ addAlert $ pairRequestReceivedAlert repo - AlertButton - { buttonUrl = url - , buttonLabel = T.pack "Respond" - , buttonAction = Just closealert - } + button <- mkAlertButton (T.pack "Respond") urlrenderer (FinishLocalPairR msg) + void $ addAlert $ pairRequestReceivedAlert repo button where repo = pairRepo msg diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index f2da99261..acbac6437 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -12,6 +12,7 @@ import Assistant.DaemonStatus import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Alert +import Assistant.Alert.Utility import Assistant.Commits import Assistant.Drop import Assistant.TransferrerPool diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 8ccb241bb..6f15505fe 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -18,7 +18,7 @@ import Assistant.Sync import Assistant.DaemonStatus import qualified Remote import Utility.ThreadScheduler -import Assistant.WebApp (UrlRenderer, renderUrl) +import Assistant.WebApp (UrlRenderer) import Assistant.WebApp.Types hiding (liftAssistant) import Assistant.WebApp.Configurators.XMPP (checkCloudRepos) import Assistant.Alert @@ -281,16 +281,12 @@ pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid finishXMPPPairing theirjid theiruuid -- Show an alert to let the user decide if they want to pair. showalert = do - let route = ConfirmXMPPPairFriendR $ - PairKey theiruuid $ formatJID theirjid - url <- liftIO $ renderUrl urlrenderer route [] - close <- asIO1 removeAlert - void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName theirjid) - AlertButton - { buttonUrl = url - , buttonLabel = T.pack "Respond" - , buttonAction = Just close - } + button <- mkAlertButton (T.pack "Respond") urlrenderer $ + ConfirmXMPPPairFriendR $ + PairKey theiruuid $ formatJID theirjid + void $ addAlert $ pairRequestReceivedAlert + (T.unpack $ buddyName theirjid) + button pairMsgReceived _ PairAck theiruuid _selfjid theirjid = {- PairAck must come from one of the buddies we are pairing with; diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs new file mode 100644 index 000000000..34bbc1b08 --- /dev/null +++ b/Assistant/Types/Alert.hs @@ -0,0 +1,74 @@ +{- git-annex assistant alert types + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.Alert where + +import Utility.Tense + +import Data.Text (Text) +import qualified Data.Map as M + +{- 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 + | RemoteRemovalAlert String + | CloudRepoNeededAlert + | SyncAlert + 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 + +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 + +{- 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 ()) + } diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 99baf1572..17e535b6d 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -10,12 +10,12 @@ module Assistant.Types.DaemonStatus where import Common.Annex -import Assistant.Alert import Assistant.Pairing import Utility.NotificationBroadcaster import Logs.Transfer import Assistant.Types.ThreadName import Assistant.Types.NetMessager +import Assistant.Types.Alert import Control.Concurrent.STM import Control.Concurrent.Async |