183f7355cd
When an automatic upgrade completes, or when the user clicks on the upgrade button in one webapp, but also has it open in another browser window/tab, we have a problem: The current web server is going to stop running in minutes, but there is no way to send a redirect to the web browser to the new url. To solve this, used long polling, so the webapp is always listening for urls it should redirect to. This allows globally redirecting every open webapp. Works great! Tested with 2 web browsers with 2 tabs each. May be useful for other purposes later too, dunno. The overhead is 2 http requests per page load in the webapp. Due to yesod's speed, this does not seem to noticibly delay it. Only 1 of the requests could possibly block the page load, the other is async.
427 lines
13 KiB
Haskell
427 lines
13 KiB
Haskell
{- git-annex assistant alerts
|
|
-
|
|
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# 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 Types.Distribution
|
|
|
|
import Data.String
|
|
import qualified Data.Text as T
|
|
import qualified Control.Exception as E
|
|
|
|
#ifdef WITH_WEBAPP
|
|
import Assistant.DaemonStatus
|
|
import Assistant.WebApp.Types
|
|
import Assistant.WebApp (renderUrl)
|
|
import Yesod
|
|
#endif
|
|
import Assistant.Monad
|
|
import Assistant.Types.UrlRenderer
|
|
|
|
{- Makes a button for an alert that opens a Route.
|
|
-
|
|
- If autoclose is set, the button will close the alert it's
|
|
- attached to when clicked. -}
|
|
#ifdef WITH_WEBAPP
|
|
mkAlertButton :: Bool -> T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
|
|
mkAlertButton autoclose label urlrenderer route = do
|
|
close <- asIO1 removeAlert
|
|
url <- liftIO $ renderUrl urlrenderer route []
|
|
return $ AlertButton
|
|
{ buttonLabel = label
|
|
, buttonUrl = url
|
|
, buttonAction = if autoclose then Just close else Nothing
|
|
, buttonPrimary = True
|
|
}
|
|
#endif
|
|
|
|
renderData :: Alert -> TenseText
|
|
renderData = tenseWords . alertData
|
|
|
|
baseActivityAlert :: Alert
|
|
baseActivityAlert = Alert
|
|
{ alertClass = Activity
|
|
, alertHeader = Nothing
|
|
, alertMessageRender = renderData
|
|
, alertData = []
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = False
|
|
, alertClosable = False
|
|
, alertPriority = Medium
|
|
, alertIcon = Just ActivityIcon
|
|
, alertCombiner = Nothing
|
|
, alertName = Nothing
|
|
, alertButtons = []
|
|
}
|
|
|
|
warningAlert :: String -> String -> Alert
|
|
warningAlert name msg = Alert
|
|
{ alertClass = Warning
|
|
, alertHeader = Just $ tenseWords ["warning"]
|
|
, alertMessageRender = renderData
|
|
, alertData = [UnTensed $ T.pack msg]
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = True
|
|
, alertClosable = True
|
|
, alertPriority = High
|
|
, alertIcon = Just ErrorIcon
|
|
, alertCombiner = Just $ dataCombiner $ \_old new -> new
|
|
, alertName = Just $ WarningAlert name
|
|
, alertButtons = []
|
|
}
|
|
|
|
errorAlert :: String -> AlertButton -> Alert
|
|
errorAlert msg button = Alert
|
|
{ alertClass = Error
|
|
, alertHeader = Nothing
|
|
, alertMessageRender = renderData
|
|
, alertData = [UnTensed $ T.pack msg]
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = True
|
|
, alertClosable = True
|
|
, alertPriority = Pinned
|
|
, alertIcon = Just ErrorIcon
|
|
, alertCombiner = Nothing
|
|
, alertName = Nothing
|
|
, alertButtons = [button]
|
|
}
|
|
|
|
activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
|
|
activityAlert header dat = baseActivityAlert
|
|
{ alertHeader = header
|
|
, alertData = dat
|
|
}
|
|
|
|
startupScanAlert :: Alert
|
|
startupScanAlert = activityAlert Nothing
|
|
[Tensed "Performing" "Performed", "startup scan"]
|
|
|
|
{- Displayed when a shutdown is occurring, so will be seen after shutdown
|
|
- has happened. -}
|
|
shutdownAlert :: Alert
|
|
shutdownAlert = warningAlert "shutdown" "git-annex has been shut down"
|
|
|
|
commitAlert :: Alert
|
|
commitAlert = activityAlert Nothing
|
|
[Tensed "Committing" "Committed", "changes to git"]
|
|
|
|
showRemotes :: [Remote] -> TenseChunk
|
|
showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name)
|
|
|
|
syncAlert :: [Remote] -> Alert
|
|
syncAlert rs = baseActivityAlert
|
|
{ alertName = Just SyncAlert
|
|
, alertHeader = Just $ tenseWords
|
|
[Tensed "Syncing" "Synced", "with", showRemotes rs]
|
|
, alertPriority = Low
|
|
, alertIcon = Just SyncIcon
|
|
}
|
|
|
|
syncResultAlert :: [Remote] -> [Remote] -> Alert
|
|
syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $
|
|
baseActivityAlert
|
|
{ alertName = Just SyncAlert
|
|
, alertHeader = Just $ tenseWords msg
|
|
}
|
|
where
|
|
msg
|
|
| null succeeded = ["Failed to sync with", showRemotes failed]
|
|
| null failed = ["Synced with", showRemotes succeeded]
|
|
| otherwise =
|
|
[ "Synced with", showRemotes succeeded
|
|
, "but not with", showRemotes failed
|
|
]
|
|
|
|
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]
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = True
|
|
, alertPriority = High
|
|
, alertClosable = True
|
|
, alertIcon = Just ErrorIcon
|
|
, alertName = Just SanityCheckFixAlert
|
|
, alertCombiner = Just $ dataCombiner (++)
|
|
, alertButtons = []
|
|
}
|
|
where
|
|
render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot]
|
|
alerthead = "The daily sanity check found and fixed a problem:"
|
|
alertfoot = "If these problems persist, consider filing a bug report."
|
|
|
|
fsckingAlert :: AlertButton -> Maybe Remote -> Alert
|
|
fsckingAlert button mr = baseActivityAlert
|
|
{ alertData = case mr of
|
|
Nothing -> [ UnTensed $ T.pack $ "Consistency check in progress" ]
|
|
Just r -> [ UnTensed $ T.pack $ "Consistency check of " ++ Remote.name r ++ " in progress"]
|
|
, alertButtons = [button]
|
|
}
|
|
|
|
showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a
|
|
showFscking urlrenderer mr a = do
|
|
#ifdef WITH_WEBAPP
|
|
button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR
|
|
r <- alertDuring (fsckingAlert button mr) $
|
|
liftIO a
|
|
#else
|
|
r <- liftIO a
|
|
#endif
|
|
either (liftIO . E.throwIO) return r
|
|
|
|
notFsckedNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
|
|
#ifdef WITH_WEBAPP
|
|
notFsckedNudge urlrenderer mr = do
|
|
button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigFsckR
|
|
void $ addAlert (notFsckedAlert mr button)
|
|
#else
|
|
notFsckedNudge _ _ = noop
|
|
#endif
|
|
|
|
notFsckedAlert :: Maybe Remote -> AlertButton -> Alert
|
|
notFsckedAlert mr button = Alert
|
|
{ alertHeader = Just $ fromString $ concat
|
|
[ "You should enable consistency checking to protect your data"
|
|
, maybe "" (\r -> " in " ++ Remote.name r) mr
|
|
, "."
|
|
]
|
|
, alertIcon = Just InfoIcon
|
|
, alertPriority = High
|
|
, alertButtons = [button]
|
|
, alertClosable = True
|
|
, alertClass = Message
|
|
, alertMessageRender = renderData
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = True
|
|
, alertName = Just NotFsckedAlert
|
|
, alertCombiner = Just $ dataCombiner $ \_old new -> new
|
|
, alertData = []
|
|
}
|
|
|
|
baseUpgradeAlert :: [AlertButton] -> TenseText -> Alert
|
|
baseUpgradeAlert buttons message = Alert
|
|
{ alertHeader = Just message
|
|
, alertIcon = Just UpgradeIcon
|
|
, alertPriority = High
|
|
, alertButtons = buttons
|
|
, alertClosable = True
|
|
, alertClass = Message
|
|
, alertMessageRender = renderData
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = True
|
|
, alertName = Just UpgradeAlert
|
|
, alertCombiner = Just $ fullCombiner $ \new _old -> new
|
|
, alertData = []
|
|
}
|
|
|
|
canUpgradeAlert :: AlertPriority -> AlertButton -> Alert
|
|
canUpgradeAlert priority button =
|
|
(baseUpgradeAlert [button] $ fromString msg)
|
|
{ alertPriority = priority }
|
|
where
|
|
msg = if priority >= High
|
|
then "An important upgrade of git-annex is available!"
|
|
else "An upgrade of git-annex is available."
|
|
|
|
upgradeReadyAlert :: AlertButton -> Alert
|
|
upgradeReadyAlert button = baseUpgradeAlert [button] $
|
|
fromString "A new version of git-annex has been installed."
|
|
|
|
upgradingAlert :: Alert
|
|
upgradingAlert = activityAlert Nothing [ fromString "Upgrading git-annex" ]
|
|
|
|
upgradeFinishedAlert :: Maybe AlertButton -> GitAnnexVersion -> Alert
|
|
upgradeFinishedAlert button version =
|
|
baseUpgradeAlert (maybe [] (:[]) button) $ fromString $
|
|
"Finished upgrading git-annex to version " ++ version
|
|
|
|
brokenRepositoryAlert :: AlertButton -> Alert
|
|
brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"
|
|
|
|
repairingAlert :: String -> Alert
|
|
repairingAlert repodesc = activityAlert Nothing
|
|
[ Tensed "Attempting to repair" "Repaired"
|
|
, UnTensed $ T.pack repodesc
|
|
]
|
|
|
|
pairingAlert :: AlertButton -> Alert
|
|
pairingAlert button = baseActivityAlert
|
|
{ alertData = [ UnTensed "Pairing in progress" ]
|
|
, alertPriority = High
|
|
, alertButtons = [button]
|
|
}
|
|
|
|
pairRequestReceivedAlert :: String -> AlertButton -> Alert
|
|
pairRequestReceivedAlert who button = Alert
|
|
{ alertClass = Message
|
|
, alertHeader = Nothing
|
|
, alertMessageRender = renderData
|
|
, alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."]
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = False
|
|
, alertPriority = High
|
|
, alertClosable = True
|
|
, alertIcon = Just InfoIcon
|
|
, alertName = Just $ PairAlert who
|
|
, alertCombiner = Just $ dataCombiner $ \_old new -> new
|
|
, alertButtons = [button]
|
|
}
|
|
|
|
pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
|
|
pairRequestAcknowledgedAlert who button = baseActivityAlert
|
|
{ alertData = ["Pairing with", UnTensed (T.pack who), Tensed "in progress" "complete"]
|
|
, alertPriority = High
|
|
, alertName = Just $ PairAlert who
|
|
, alertCombiner = Just $ dataCombiner $ \_old new -> new
|
|
, alertButtons = maybe [] (:[]) button
|
|
}
|
|
|
|
xmppNeededAlert :: AlertButton -> Alert
|
|
xmppNeededAlert button = Alert
|
|
{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
|
|
, alertIcon = Just TheCloud
|
|
, alertPriority = High
|
|
, alertButtons = [button]
|
|
, alertClosable = True
|
|
, alertClass = Message
|
|
, alertMessageRender = renderData
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = True
|
|
, alertName = Just $ XMPPNeededAlert
|
|
, alertCombiner = Just $ dataCombiner $ \_old new -> new
|
|
, alertData = []
|
|
}
|
|
|
|
cloudRepoNeededAlert :: Maybe String -> AlertButton -> Alert
|
|
cloudRepoNeededAlert friendname button = Alert
|
|
{ alertHeader = Just $ fromString $ unwords
|
|
[ "Unable to download files from"
|
|
, (fromMaybe "your other devices" friendname) ++ "."
|
|
]
|
|
, alertIcon = Just ErrorIcon
|
|
, alertPriority = High
|
|
, alertButtons = [button]
|
|
, alertClosable = True
|
|
, alertClass = Message
|
|
, alertMessageRender = renderData
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = True
|
|
, alertName = Just $ CloudRepoNeededAlert
|
|
, alertCombiner = Just $ dataCombiner $ \_old new -> new
|
|
, alertData = []
|
|
}
|
|
|
|
remoteRemovalAlert :: String -> AlertButton -> Alert
|
|
remoteRemovalAlert desc button = Alert
|
|
{ alertHeader = Just $ fromString $
|
|
"The repository \"" ++ desc ++
|
|
"\" has been emptied, and can now be removed."
|
|
, alertIcon = Just InfoIcon
|
|
, alertPriority = High
|
|
, alertButtons = [button]
|
|
, alertClosable = True
|
|
, alertClass = Message
|
|
, alertMessageRender = renderData
|
|
, alertCounter = 0
|
|
, alertBlockDisplay = True
|
|
, alertName = Just $ RemoteRemovalAlert desc
|
|
, alertCombiner = Just $ dataCombiner $ \_old new -> new
|
|
, alertData = []
|
|
}
|
|
|
|
{- Show a message that relates to a list of files.
|
|
-
|
|
- The most recent several files are shown, and a count of any others. -}
|
|
fileAlert :: TenseChunk -> [FilePath] -> Alert
|
|
fileAlert msg files = (activityAlert Nothing shortfiles)
|
|
{ alertName = Just $ FileAlert msg
|
|
, alertMessageRender = renderer
|
|
, alertCounter = counter
|
|
, alertCombiner = Just $ fullCombiner combiner
|
|
}
|
|
where
|
|
maxfilesshown = 10
|
|
|
|
(somefiles, counter) = splitcounter (dedupadjacent files)
|
|
shortfiles = map (fromString . shortFile . takeFileName) somefiles
|
|
|
|
renderer alert = tenseWords $ msg : alertData alert ++ showcounter
|
|
where
|
|
showcounter = case alertCounter alert of
|
|
0 -> []
|
|
_ -> [fromString $ "and " ++ show (alertCounter alert) ++ " other files"]
|
|
|
|
dedupadjacent (x:y:rest)
|
|
| x == y = dedupadjacent (y:rest)
|
|
| otherwise = x : dedupadjacent (y:rest)
|
|
dedupadjacent (x:[]) = [x]
|
|
dedupadjacent [] = []
|
|
|
|
{- Note that this ensures the counter is never 1; no need to say
|
|
- "1 file" when the filename could be shown. -}
|
|
splitcounter l
|
|
| length l <= maxfilesshown = (l, 0)
|
|
| otherwise =
|
|
let (keep, rest) = splitAt (maxfilesshown - 1) l
|
|
in (keep, length rest)
|
|
|
|
combiner new old =
|
|
let (fs, n) = splitcounter $
|
|
dedupadjacent $ alertData new ++ alertData old
|
|
cnt = n + alertCounter new + alertCounter old
|
|
in old
|
|
{ alertData = fs
|
|
, alertCounter = cnt
|
|
}
|
|
|
|
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 file
|
|
| direction == Upload = fileAlert "Uploaded" [file]
|
|
| otherwise = fileAlert "Downloaded" [file]
|
|
transferFileAlert direction False file
|
|
| direction == Upload = fileAlert "Upload failed" [file]
|
|
| otherwise = fileAlert "Download failed" [file]
|
|
|
|
dataCombiner :: ([TenseChunk] -> [TenseChunk] -> [TenseChunk]) -> AlertCombiner
|
|
dataCombiner combiner = fullCombiner $
|
|
\new old -> old { alertData = alertData new `combiner` alertData old }
|
|
|
|
fullCombiner :: (Alert -> Alert -> Alert) -> AlertCombiner
|
|
fullCombiner combiner new old
|
|
| alertClass new /= alertClass old = Nothing
|
|
| alertName new == alertName old =
|
|
Just $! new `combiner` 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
|
|
|