From d24f7f94fe2a7d670ddff710aa1cf3c67e13e7ee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 23 Nov 2013 12:39:36 -0400 Subject: [PATCH] better UI flow through upgrade process Move button to enable automatic upgrades to an alert displayed after successful upgrade. Unclutters the UI and makes psychological sense. --- Assistant/Alert.hs | 51 +++++++++++------------ Assistant/Threads/UpgradeWatcher.hs | 25 ++++++++--- Assistant/Types/Alert.hs | 3 +- Assistant/Upgrade.hs | 8 ++++ Assistant/WebApp/Configurators/Upgrade.hs | 13 +++--- Assistant/WebApp/routes | 3 +- 6 files changed, 63 insertions(+), 40 deletions(-) diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 25a75eeabe..e7d3e103d9 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -15,6 +15,7 @@ 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 @@ -216,44 +217,42 @@ notFsckedAlert mr button = Alert , alertData = [] } -canUpgradeAlert :: AlertPriority -> AlertButton -> Alert -canUpgradeAlert priority button = Alert - { alertHeader = Just $ fromString $ - if priority >= High - then "An important upgrade of git-annex is available!" - else "An upgrade of git-annex is available." +baseUpgradeAlert :: AlertButton -> TenseText -> Alert +baseUpgradeAlert button message = Alert + { alertHeader = Just message , alertIcon = Just UpgradeIcon - , alertPriority = priority + , alertPriority = High , alertButtons = [button] , alertClosable = True , alertClass = Message , alertMessageRender = renderData , alertCounter = 0 , alertBlockDisplay = True - , alertName = Just CanUpgradeAlert - , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertName = Just UpgradeAlert + , alertCombiner = Just $ fullCombiner $ \new _old -> new , alertData = [] } -upgradeReadyAlert :: [AlertButton] -> Alert -upgradeReadyAlert buttons = Alert - { alertHeader = Just $ fromString - "A new version of git-annex has been installed." - , alertIcon = Just UpgradeIcon - , alertPriority = High - , alertButtons = buttons - , alertClosable = True - , alertClass = Message - , alertMessageRender = renderData - , alertCounter = 0 - , alertBlockDisplay = True - , alertName = Just UpgradeReadyAlert - , alertCombiner = Just $ dataCombiner $ \_old new -> 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"] +upgradingAlert = activityAlert Nothing [ fromString "Upgrading git-annex" ] + +upgradeFinishedAlert :: AlertButton -> GitAnnexVersion -> Alert +upgradeFinishedAlert button version = + baseUpgradeAlert 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!" diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs index 7d0da58181..7cb42e5979 100644 --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -23,6 +23,7 @@ import Assistant.Alert import Assistant.DaemonStatus #ifdef WITH_WEBAPP import Assistant.WebApp.Types +import qualified Build.SysConfig #endif import qualified Annex import Types.Distribution @@ -35,7 +36,10 @@ data WatcherState = InStartupScan | Started | Upgrading deriving (Eq) upgradWatcherThread :: UrlRenderer -> NamedThread -upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ go =<< liftIO programPath +upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do + whenM (liftIO $ checkSuccessfulUpgrade) $ + showSuccessfulUpgrade urlrenderer + go =<< liftIO programPath where go Nothing = debug [ "cannot determine program path" ] go (Just program) = do @@ -80,7 +84,7 @@ changedFile urlrenderer mvar program file _status -} sanityCheck :: FilePath -> Assistant Bool sanityCheck program = do - untilM (liftIO $ nowriter <&&> present) $ do + untilM (liftIO $ present <&&> nowriter) $ do debug [program, "is still being written; waiting"] liftIO $ threadDelaySeconds (Seconds 60) debug [program, "has changed, and seems to be ready to run"] @@ -104,11 +108,20 @@ handleUpgrade urlrenderer = do unattendedUpgrade #ifdef WITH_WEBAPP , do - finish <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer (ConfigFinishUpgradeR False) - noask <- mkAlertButton True (T.pack "Always Upgrade Automatically") urlrenderer (ConfigFinishUpgradeR True) - void $ addAlert $ upgradeReadyAlert - [finish, noask { buttonPrimary = False }] + button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR + void $ addAlert $ upgradeReadyAlert button #else , noop #endif ) + +showSuccessfulUpgrade :: UrlRenderer -> Assistant () +showSuccessfulUpgrade urlrenderer = do +#ifdef WITH_WEBAPP + button <- mkAlertButton True + (T.pack "Enable Automatic Upgrades") + urlrenderer ConfigEnableAutomaticUpgradeR + void $ addAlert $ upgradeFinishedAlert button Build.SysConfig.packageversion +#else + noop +#endif diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs index 4079802eca..e6fbe86d39 100644 --- a/Assistant/Types/Alert.hs +++ b/Assistant/Types/Alert.hs @@ -31,8 +31,7 @@ data AlertName | CloudRepoNeededAlert | SyncAlert | NotFsckedAlert - | CanUpgradeAlert - | UpgradeReadyAlert + | UpgradeAlert deriving (Eq) {- The first alert is the new alert, the second is an old alert. diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 8e8e1232d8..c628e1bc6b 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -14,6 +14,7 @@ import Assistant.Alert import Assistant.DaemonStatus import Assistant.NamedThread import Utility.ThreadScheduler +import Utility.Env import Git import Config.Files @@ -32,6 +33,7 @@ prepUpgrade = do liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile) + void $ liftIO $ setEnv upgradedEnv "1" True {- Wait for browser to update before terminating this process. -} postUpgrade :: IO () @@ -59,3 +61,9 @@ startAssistant repo = do createProcess $ (proc program ["assistant"]) { cwd = Just repo } void $ checkSuccessProcess pid + +checkSuccessfulUpgrade :: IO Bool +checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv + +upgradedEnv :: String +upgradedEnv = "GIT_ANNEX_UPGRADED" diff --git a/Assistant/WebApp/Configurators/Upgrade.hs b/Assistant/WebApp/Configurators/Upgrade.hs index cfa07f5687..1b1d146f25 100644 --- a/Assistant/WebApp/Configurators/Upgrade.hs +++ b/Assistant/WebApp/Configurators/Upgrade.hs @@ -35,13 +35,16 @@ getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do - the others will show the upgradingAlert, and keep running until - this process is terminated. -} -getConfigFinishUpgradeR :: Bool -> Handler Html -getConfigFinishUpgradeR enableautoupgrade = do - when enableautoupgrade $ liftAnnex $ - setConfig (annexConfig "autoupgrade") - (fromAutoUpgrade AutoUpgrade) +getConfigFinishUpgradeR :: Handler Html +getConfigFinishUpgradeR = do liftAssistant prepUpgrade liftIO postUpgrade `after` startnewprocess where startnewprocess = switchToAssistant =<< liftAnnex (repoLocation <$> Annex.gitRepo) + +getConfigEnableAutomaticUpgradeR :: Handler Html +getConfigEnableAutomaticUpgradeR = do + liftAnnex $ setConfig (annexConfig "autoupgrade") + (fromAutoUpgrade AutoUpgrade) + redirect DashboardR diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index a027ad9387..89a9132b93 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -22,7 +22,8 @@ /config/fsck ConfigFsckR GET POST /config/fsck/preferences ConfigFsckPreferencesR POST /config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET -/config/upgrade/finish/#Bool ConfigFinishUpgradeR GET +/config/upgrade/finish ConfigFinishUpgradeR GET +/config/upgrade/automatically ConfigEnableAutomaticUpgradeR GET /config/addrepository AddRepositoryR GET /config/repository/new NewRepositoryR GET POST