refactor alert button creation code

This commit is contained in:
Joey Hess 2013-04-04 01:48:26 -04:00
parent 628637c633
commit 8b329c0317
16 changed files with 267 additions and 235 deletions

View file

@ -152,6 +152,7 @@ import Assistant.Threads.XMPPClient
#endif
#else
#warning Building without the webapp. You probably need to install Yesod..
import Assistant.Types.UrlRenderer
#endif
import Assistant.Environment
import qualified Utility.Daemon

View file

@ -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)
#ifdef WITH_WEBAPP
import Assistant.Monad
import Assistant.DaemonStatus
import Assistant.WebApp.Types
import Assistant.WebApp
import Yesod.Core
#endif
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
{- 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

130
Assistant/Alert/Utility.hs Normal file
View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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;

74
Assistant/Types/Alert.hs Normal file
View file

@ -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 ())
}

View file

@ -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

View file

@ -57,14 +57,9 @@ checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
checkCloudRepos urlrenderer r =
unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
buddyname <- getBuddyName $ Remote.uuid r
url <- liftIO $
renderUrl urlrenderer (NeedCloudRepoR $ Remote.uuid r) []
close <- asIO1 removeAlert
void $ addAlert $ cloudRepoNeededAlert buddyname $ AlertButton
{ buttonLabel = "Add a cloud repository"
, buttonUrl = url
, buttonAction = Just close
}
button <- mkAlertButton "Add a cloud repository" urlrenderer $
NeedCloudRepoR $ Remote.uuid r
void $ addAlert $ cloudRepoNeededAlert buddyname button
#else
checkCloudRepos _ _ = noop
#endif

View file

@ -13,7 +13,7 @@ import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.Notifications
import Assistant.Alert
import Assistant.Alert.Utility
import Assistant.DaemonStatus
import Utility.NotificationBroadcaster
import Utility.Yesod

View file

@ -14,7 +14,6 @@ module Assistant.WebApp.Types where
import Assistant.Common
import Assistant.Ssh
import Assistant.Alert
import Assistant.Pairing
import Assistant.Types.Buddies
import Utility.NotificationBroadcaster