refactor alert button creation code
This commit is contained in:
parent
628637c633
commit
8b329c0317
16 changed files with 267 additions and 235 deletions
|
@ -152,6 +152,7 @@ import Assistant.Threads.XMPPClient
|
||||||
#endif
|
#endif
|
||||||
#else
|
#else
|
||||||
#warning Building without the webapp. You probably need to install Yesod..
|
#warning Building without the webapp. You probably need to install Yesod..
|
||||||
|
import Assistant.Types.UrlRenderer
|
||||||
#endif
|
#endif
|
||||||
import Assistant.Environment
|
import Assistant.Environment
|
||||||
import qualified Utility.Daemon
|
import qualified Utility.Daemon
|
||||||
|
|
|
@ -1,198 +1,45 @@
|
||||||
{- git-annex assistant alerts
|
{- 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.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings, CPP #-}
|
||||||
|
|
||||||
module Assistant.Alert where
|
module Assistant.Alert where
|
||||||
|
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
|
import Assistant.Types.Alert
|
||||||
|
import Assistant.Alert.Utility
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Utility.Tense
|
import Utility.Tense
|
||||||
import Logs.Transfer
|
import Logs.Transfer
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.Text (Text)
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.String
|
import Data.String
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
{- Different classes of alerts are displayed differently. -}
|
#ifdef WITH_WEBAPP
|
||||||
data AlertClass = Success | Message | Activity | Warning | Error
|
import Assistant.Monad
|
||||||
deriving (Eq, Ord)
|
import Assistant.DaemonStatus
|
||||||
|
import Assistant.WebApp.Types
|
||||||
|
import Assistant.WebApp
|
||||||
|
import Yesod.Core
|
||||||
|
#endif
|
||||||
|
|
||||||
data AlertPriority = Filler | Low | Medium | High | Pinned
|
{- Makes a button for an alert that opens a Route. The button will
|
||||||
deriving (Eq, Ord)
|
- close the alert it's attached to when clicked. -}
|
||||||
|
#ifdef WITH_WEBAPP
|
||||||
{- An alert can have an name, which is used to combine it with other similar
|
mkAlertButton :: T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
|
||||||
- alerts. -}
|
mkAlertButton label urlrenderer route = do
|
||||||
data AlertName
|
close <- asIO1 removeAlert
|
||||||
= FileAlert TenseChunk
|
url <- liftIO $ renderUrl urlrenderer route []
|
||||||
| SanityCheckFixAlert
|
return $ AlertButton
|
||||||
| WarningAlert String
|
{ buttonLabel = label
|
||||||
| PairAlert String
|
, buttonUrl = url
|
||||||
| XMPPNeededAlert
|
, buttonAction = Just close
|
||||||
| 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
|
|
||||||
}
|
}
|
||||||
where
|
#endif
|
||||||
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
|
||||||
baseActivityAlert = Alert
|
baseActivityAlert = Alert
|
||||||
|
|
130
Assistant/Alert/Utility.hs
Normal file
130
Assistant/Alert/Utility.hs
Normal 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
|
|
@ -11,3 +11,4 @@ import Common.Annex as X
|
||||||
import Assistant.Monad as X
|
import Assistant.Monad as X
|
||||||
import Assistant.Types.DaemonStatus as X
|
import Assistant.Types.DaemonStatus as X
|
||||||
import Assistant.Types.NamedThread as X
|
import Assistant.Types.NamedThread as X
|
||||||
|
import Assistant.Types.Alert as X
|
||||||
|
|
|
@ -8,7 +8,7 @@
|
||||||
module Assistant.DaemonStatus where
|
module Assistant.DaemonStatus where
|
||||||
|
|
||||||
import Assistant.Common
|
import Assistant.Common
|
||||||
import Assistant.Alert
|
import Assistant.Alert.Utility
|
||||||
import Utility.TempFile
|
import Utility.TempFile
|
||||||
import Assistant.Types.NetMessager
|
import Assistant.Types.NetMessager
|
||||||
import Utility.NotificationBroadcaster
|
import Utility.NotificationBroadcaster
|
||||||
|
|
|
@ -10,14 +10,10 @@
|
||||||
module Assistant.DeleteRemote where
|
module Assistant.DeleteRemote where
|
||||||
|
|
||||||
import Assistant.Common
|
import Assistant.Common
|
||||||
#ifdef WITH_WEBAPP
|
import Assistant.Types.UrlRenderer
|
||||||
import Assistant.WebApp.Types
|
|
||||||
import Assistant.WebApp
|
|
||||||
#endif
|
|
||||||
import Assistant.TransferQueue
|
import Assistant.TransferQueue
|
||||||
import Logs.Transfer
|
import Logs.Transfer
|
||||||
import Logs.Location
|
import Logs.Location
|
||||||
import Assistant.Alert
|
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Remote.List
|
import Remote.List
|
||||||
|
@ -25,7 +21,12 @@ import qualified Git.Command
|
||||||
import Logs.Trust
|
import Logs.Trust
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
|
||||||
|
#ifdef WITH_WEBAPP
|
||||||
|
import Assistant.WebApp.Types
|
||||||
|
import Assistant.WebApp
|
||||||
|
import Assistant.Alert
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
#endif
|
||||||
|
|
||||||
{- Removes a remote (but leave the repository as-is), and returns the old
|
{- Removes a remote (but leave the repository as-is), and returns the old
|
||||||
- Remote data. -}
|
- Remote data. -}
|
||||||
|
@ -82,16 +83,12 @@ removableRemote urlrenderer uuid = do
|
||||||
- Without the webapp, just do the removal now.
|
- Without the webapp, just do the removal now.
|
||||||
-}
|
-}
|
||||||
finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
|
finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
|
||||||
finishRemovingRemote urlrenderer uuid = do
|
|
||||||
#ifdef WITH_WEBAPP
|
#ifdef WITH_WEBAPP
|
||||||
|
finishRemovingRemote urlrenderer uuid = do
|
||||||
desc <- liftAnnex $ Remote.prettyUUID uuid
|
desc <- liftAnnex $ Remote.prettyUUID uuid
|
||||||
url <- liftIO $ renderUrl urlrenderer (FinishDeleteRepositoryR uuid) []
|
button <- mkAlertButton (T.pack "Finish deletion process") urlrenderer $
|
||||||
close <- asIO1 removeAlert
|
FinishDeleteRepositoryR uuid
|
||||||
void $ addAlert $ remoteRemovalAlert desc $ AlertButton
|
void $ addAlert $ remoteRemovalAlert desc button
|
||||||
{ buttonLabel = T.pack "Finish deletion process"
|
|
||||||
, buttonUrl = url
|
|
||||||
, buttonAction = Just close
|
|
||||||
}
|
|
||||||
#else
|
#else
|
||||||
|
finishRemovingRemote _ uuid = void $ removeRemote uuid
|
||||||
#endif
|
#endif
|
||||||
|
|
|
@ -23,8 +23,8 @@ import qualified Data.Map as M
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
|
|
||||||
#ifdef WITH_WEBAPP
|
#ifdef WITH_WEBAPP
|
||||||
import Assistant.WebApp
|
|
||||||
import Assistant.WebApp.Types
|
import Assistant.WebApp.Types
|
||||||
|
import Assistant.Types.Alert
|
||||||
import Assistant.Alert
|
import Assistant.Alert
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
#endif
|
#endif
|
||||||
|
@ -65,17 +65,13 @@ startNamedThread urlrenderer namedthread@(NamedThread name a) = do
|
||||||
]
|
]
|
||||||
hPutStrLn stderr msg
|
hPutStrLn stderr msg
|
||||||
#ifdef WITH_WEBAPP
|
#ifdef WITH_WEBAPP
|
||||||
button <- runAssistant d $ do
|
button <- runAssistant d $ mkAlertButton
|
||||||
close <- asIO1 removeAlert
|
(T.pack "Restart Thread")
|
||||||
url <- liftIO $ renderUrl urlrenderer (RestartThreadR name) []
|
urlrenderer
|
||||||
return $ Just $ AlertButton
|
(RestartThreadR name)
|
||||||
{ buttonLabel = T.pack "Restart Thread"
|
runAssistant d $ void $ addAlert $
|
||||||
, buttonUrl = url
|
(warningAlert (fromThreadName name) msg)
|
||||||
, buttonAction = Just close
|
{ alertButton = Just button }
|
||||||
}
|
|
||||||
runAssistant d $ void $
|
|
||||||
addAlert $ (warningAlert (fromThreadName name) msg)
|
|
||||||
{ alertButton = button }
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
|
namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
|
||||||
|
|
|
@ -12,6 +12,7 @@ import Assistant.Pushes
|
||||||
import Assistant.NetMessager
|
import Assistant.NetMessager
|
||||||
import Assistant.Types.NetMessager
|
import Assistant.Types.NetMessager
|
||||||
import Assistant.Alert
|
import Assistant.Alert
|
||||||
|
import Assistant.Alert.Utility
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import Assistant.ScanRemotes
|
import Assistant.ScanRemotes
|
||||||
import qualified Command.Sync
|
import qualified Command.Sync
|
||||||
|
|
|
@ -11,7 +11,7 @@ import Assistant.Common
|
||||||
import Assistant.Pairing
|
import Assistant.Pairing
|
||||||
import Assistant.Pairing.Network
|
import Assistant.Pairing.Network
|
||||||
import Assistant.Pairing.MakeRemote
|
import Assistant.Pairing.MakeRemote
|
||||||
import Assistant.WebApp (UrlRenderer, renderUrl)
|
import Assistant.WebApp (UrlRenderer)
|
||||||
import Assistant.WebApp.Types
|
import Assistant.WebApp.Types
|
||||||
import Assistant.Alert
|
import Assistant.Alert
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
|
@ -101,14 +101,8 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
|
||||||
pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
|
pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
|
||||||
pairReqReceived True _ _ = noop -- ignore our own PairReq
|
pairReqReceived True _ _ = noop -- ignore our own PairReq
|
||||||
pairReqReceived False urlrenderer msg = do
|
pairReqReceived False urlrenderer msg = do
|
||||||
url <- liftIO $ renderUrl urlrenderer (FinishLocalPairR msg) []
|
button <- mkAlertButton (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
|
||||||
closealert <- asIO1 removeAlert
|
void $ addAlert $ pairRequestReceivedAlert repo button
|
||||||
void $ addAlert $ pairRequestReceivedAlert repo
|
|
||||||
AlertButton
|
|
||||||
{ buttonUrl = url
|
|
||||||
, buttonLabel = T.pack "Respond"
|
|
||||||
, buttonAction = Just closealert
|
|
||||||
}
|
|
||||||
where
|
where
|
||||||
repo = pairRepo msg
|
repo = pairRepo msg
|
||||||
|
|
||||||
|
|
|
@ -12,6 +12,7 @@ import Assistant.DaemonStatus
|
||||||
import Assistant.TransferQueue
|
import Assistant.TransferQueue
|
||||||
import Assistant.TransferSlots
|
import Assistant.TransferSlots
|
||||||
import Assistant.Alert
|
import Assistant.Alert
|
||||||
|
import Assistant.Alert.Utility
|
||||||
import Assistant.Commits
|
import Assistant.Commits
|
||||||
import Assistant.Drop
|
import Assistant.Drop
|
||||||
import Assistant.TransferrerPool
|
import Assistant.TransferrerPool
|
||||||
|
|
|
@ -18,7 +18,7 @@ import Assistant.Sync
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Utility.ThreadScheduler
|
import Utility.ThreadScheduler
|
||||||
import Assistant.WebApp (UrlRenderer, renderUrl)
|
import Assistant.WebApp (UrlRenderer)
|
||||||
import Assistant.WebApp.Types hiding (liftAssistant)
|
import Assistant.WebApp.Types hiding (liftAssistant)
|
||||||
import Assistant.WebApp.Configurators.XMPP (checkCloudRepos)
|
import Assistant.WebApp.Configurators.XMPP (checkCloudRepos)
|
||||||
import Assistant.Alert
|
import Assistant.Alert
|
||||||
|
@ -281,16 +281,12 @@ pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
|
||||||
finishXMPPPairing theirjid theiruuid
|
finishXMPPPairing theirjid theiruuid
|
||||||
-- Show an alert to let the user decide if they want to pair.
|
-- Show an alert to let the user decide if they want to pair.
|
||||||
showalert = do
|
showalert = do
|
||||||
let route = ConfirmXMPPPairFriendR $
|
button <- mkAlertButton (T.pack "Respond") urlrenderer $
|
||||||
PairKey theiruuid $ formatJID theirjid
|
ConfirmXMPPPairFriendR $
|
||||||
url <- liftIO $ renderUrl urlrenderer route []
|
PairKey theiruuid $ formatJID theirjid
|
||||||
close <- asIO1 removeAlert
|
void $ addAlert $ pairRequestReceivedAlert
|
||||||
void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName theirjid)
|
(T.unpack $ buddyName theirjid)
|
||||||
AlertButton
|
button
|
||||||
{ buttonUrl = url
|
|
||||||
, buttonLabel = T.pack "Respond"
|
|
||||||
, buttonAction = Just close
|
|
||||||
}
|
|
||||||
|
|
||||||
pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
|
pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
|
||||||
{- PairAck must come from one of the buddies we are pairing with;
|
{- PairAck must come from one of the buddies we are pairing with;
|
||||||
|
|
74
Assistant/Types/Alert.hs
Normal file
74
Assistant/Types/Alert.hs
Normal 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 ())
|
||||||
|
}
|
|
@ -10,12 +10,12 @@
|
||||||
module Assistant.Types.DaemonStatus where
|
module Assistant.Types.DaemonStatus where
|
||||||
|
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import Assistant.Alert
|
|
||||||
import Assistant.Pairing
|
import Assistant.Pairing
|
||||||
import Utility.NotificationBroadcaster
|
import Utility.NotificationBroadcaster
|
||||||
import Logs.Transfer
|
import Logs.Transfer
|
||||||
import Assistant.Types.ThreadName
|
import Assistant.Types.ThreadName
|
||||||
import Assistant.Types.NetMessager
|
import Assistant.Types.NetMessager
|
||||||
|
import Assistant.Types.Alert
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
|
|
|
@ -57,14 +57,9 @@ checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
|
||||||
checkCloudRepos urlrenderer r =
|
checkCloudRepos urlrenderer r =
|
||||||
unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
|
unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
|
||||||
buddyname <- getBuddyName $ Remote.uuid r
|
buddyname <- getBuddyName $ Remote.uuid r
|
||||||
url <- liftIO $
|
button <- mkAlertButton "Add a cloud repository" urlrenderer $
|
||||||
renderUrl urlrenderer (NeedCloudRepoR $ Remote.uuid r) []
|
NeedCloudRepoR $ Remote.uuid r
|
||||||
close <- asIO1 removeAlert
|
void $ addAlert $ cloudRepoNeededAlert buddyname button
|
||||||
void $ addAlert $ cloudRepoNeededAlert buddyname $ AlertButton
|
|
||||||
{ buttonLabel = "Add a cloud repository"
|
|
||||||
, buttonUrl = url
|
|
||||||
, buttonAction = Just close
|
|
||||||
}
|
|
||||||
#else
|
#else
|
||||||
checkCloudRepos _ _ = noop
|
checkCloudRepos _ _ = noop
|
||||||
#endif
|
#endif
|
||||||
|
|
|
@ -13,7 +13,7 @@ import Assistant.Common
|
||||||
import Assistant.WebApp
|
import Assistant.WebApp
|
||||||
import Assistant.WebApp.Types
|
import Assistant.WebApp.Types
|
||||||
import Assistant.WebApp.Notifications
|
import Assistant.WebApp.Notifications
|
||||||
import Assistant.Alert
|
import Assistant.Alert.Utility
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import Utility.NotificationBroadcaster
|
import Utility.NotificationBroadcaster
|
||||||
import Utility.Yesod
|
import Utility.Yesod
|
||||||
|
|
|
@ -14,7 +14,6 @@ module Assistant.WebApp.Types where
|
||||||
|
|
||||||
import Assistant.Common
|
import Assistant.Common
|
||||||
import Assistant.Ssh
|
import Assistant.Ssh
|
||||||
import Assistant.Alert
|
|
||||||
import Assistant.Pairing
|
import Assistant.Pairing
|
||||||
import Assistant.Types.Buddies
|
import Assistant.Types.Buddies
|
||||||
import Utility.NotificationBroadcaster
|
import Utility.NotificationBroadcaster
|
||||||
|
|
Loading…
Reference in a new issue