From 6abaf19c415424240f7ea033cbf696907b71477b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 23 Nov 2013 00:54:08 -0400 Subject: [PATCH] restart on upgrade is working, including automatic restart Made alerts be able to have multiple buttons, so the alerts about upgrading can have a button that enables automatic upgrades. Implemented automatic upgrading when the program file has changed. Note that when an automatic upgrade happens, the webapp displays an alert about it for a few minutes, and then closes. This still needs work. --- Assistant/Alert.hs | 33 ++++++------ Assistant/Alert/Utility.hs | 2 +- Assistant/NamedThread.hs | 2 +- Assistant/Threads/UpgradeWatcher.hs | 23 ++++++--- Assistant/Types/Alert.hs | 3 +- Assistant/Upgrade.hs | 61 +++++++++++++++++++++++ Assistant/WebApp/Configurators/Local.hs | 2 +- Assistant/WebApp/Configurators/Pairing.hs | 1 + Assistant/WebApp/Configurators/Upgrade.hs | 35 ++++--------- Assistant/WebApp/Configurators/XMPP.hs | 1 + Assistant/WebApp/OtherRepos.hs | 12 +---- Assistant/WebApp/SideBar.hs | 21 +++++--- Assistant/WebApp/Types.hs | 4 ++ Assistant/WebApp/routes | 4 +- templates/sidebar/alert.hamlet | 7 +-- 15 files changed, 136 insertions(+), 75 deletions(-) create mode 100644 Assistant/Upgrade.hs diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index fef78c1f0a..25a75eeabe 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -42,6 +42,7 @@ mkAlertButton autoclose label urlrenderer route = do { buttonLabel = label , buttonUrl = url , buttonAction = if autoclose then Just close else Nothing + , buttonPrimary = True } #endif @@ -61,7 +62,7 @@ baseActivityAlert = Alert , alertIcon = Just ActivityIcon , alertCombiner = Nothing , alertName = Nothing - , alertButton = Nothing + , alertButtons = [] } warningAlert :: String -> String -> Alert @@ -77,7 +78,7 @@ warningAlert name msg = Alert , alertIcon = Just ErrorIcon , alertCombiner = Just $ dataCombiner $ \_old new -> new , alertName = Just $ WarningAlert name - , alertButton = Nothing + , alertButtons = [] } errorAlert :: String -> AlertButton -> Alert @@ -93,7 +94,7 @@ errorAlert msg button = Alert , alertIcon = Just ErrorIcon , alertCombiner = Nothing , alertName = Nothing - , alertButton = Just button + , alertButtons = [button] } activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert @@ -160,7 +161,7 @@ sanityCheckFixAlert msg = Alert , alertIcon = Just ErrorIcon , alertName = Just SanityCheckFixAlert , alertCombiner = Just $ dataCombiner (++) - , alertButton = Nothing + , alertButtons = [] } where render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot] @@ -172,7 +173,7 @@ 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"] - , alertButton = Just button + , alertButtons = [button] } showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a @@ -204,7 +205,7 @@ notFsckedAlert mr button = Alert ] , alertIcon = Just InfoIcon , alertPriority = High - , alertButton = Just button + , alertButtons = [button] , alertClosable = True , alertClass = Message , alertMessageRender = renderData @@ -223,7 +224,7 @@ canUpgradeAlert priority button = Alert else "An upgrade of git-annex is available." , alertIcon = Just UpgradeIcon , alertPriority = priority - , alertButton = Just button + , alertButtons = [button] , alertClosable = True , alertClass = Message , alertMessageRender = renderData @@ -234,13 +235,13 @@ canUpgradeAlert priority button = Alert , alertData = [] } -upgradeReadyAlert :: AlertButton -> Alert -upgradeReadyAlert button = Alert +upgradeReadyAlert :: [AlertButton] -> Alert +upgradeReadyAlert buttons = Alert { alertHeader = Just $ fromString "A new version of git-annex has been installed." , alertIcon = Just UpgradeIcon , alertPriority = High - , alertButton = Just button + , alertButtons = buttons , alertClosable = True , alertClass = Message , alertMessageRender = renderData @@ -267,7 +268,7 @@ pairingAlert :: AlertButton -> Alert pairingAlert button = baseActivityAlert { alertData = [ UnTensed "Pairing in progress" ] , alertPriority = High - , alertButton = Just button + , alertButtons = [button] } pairRequestReceivedAlert :: String -> AlertButton -> Alert @@ -283,7 +284,7 @@ pairRequestReceivedAlert who button = Alert , alertIcon = Just InfoIcon , alertName = Just $ PairAlert who , alertCombiner = Just $ dataCombiner $ \_old new -> new - , alertButton = Just button + , alertButtons = [button] } pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert @@ -292,7 +293,7 @@ pairRequestAcknowledgedAlert who button = baseActivityAlert , alertPriority = High , alertName = Just $ PairAlert who , alertCombiner = Just $ dataCombiner $ \_old new -> new - , alertButton = button + , alertButtons = maybe [] (:[]) button } xmppNeededAlert :: AlertButton -> Alert @@ -300,7 +301,7 @@ xmppNeededAlert button = Alert { alertHeader = Just "Share with friends, and keep your devices in sync across the cloud." , alertIcon = Just TheCloud , alertPriority = High - , alertButton = Just button + , alertButtons = [button] , alertClosable = True , alertClass = Message , alertMessageRender = renderData @@ -319,7 +320,7 @@ cloudRepoNeededAlert friendname button = Alert ] , alertIcon = Just ErrorIcon , alertPriority = High - , alertButton = Just button + , alertButtons = [button] , alertClosable = True , alertClass = Message , alertMessageRender = renderData @@ -337,7 +338,7 @@ remoteRemovalAlert desc button = Alert "\" has been emptied, and can now be removed." , alertIcon = Just InfoIcon , alertPriority = High - , alertButton = Just button + , alertButtons = [button] , alertClosable = True , alertClass = Message , alertMessageRender = renderData diff --git a/Assistant/Alert/Utility.hs b/Assistant/Alert/Utility.hs index af52a4235d..db2ea19250 100644 --- a/Assistant/Alert/Utility.hs +++ b/Assistant/Alert/Utility.hs @@ -87,7 +87,7 @@ makeAlertFiller success alert { alertClass = if c == Activity then c' else c , alertPriority = Filler , alertClosable = True - , alertButton = Nothing + , alertButtons = [] , alertIcon = Just $ if success then SuccessIcon else ErrorIcon } where diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index 2440c45bf5..e1b3983f76 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -82,7 +82,7 @@ startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do (RestartThreadR name) runAssistant d $ void $ addAlert $ (warningAlert (fromThreadName name) msg) - { alertButton = Just button } + { alertButtons = [button] } #endif namedThreadId :: NamedThread -> Assistant (Maybe ThreadId) diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs index acf68a0a65..7d0da58181 100644 --- a/Assistant/Threads/UpgradeWatcher.hs +++ b/Assistant/Threads/UpgradeWatcher.hs @@ -12,6 +12,7 @@ module Assistant.Threads.UpgradeWatcher ( ) where import Assistant.Common +import Assistant.Upgrade import Utility.DirWatcher import Utility.DirWatcher.Types import Config.Files @@ -23,6 +24,8 @@ import Assistant.DaemonStatus #ifdef WITH_WEBAPP import Assistant.WebApp.Types #endif +import qualified Annex +import Types.Distribution import Control.Concurrent.MVar import Data.Tuple.Utils @@ -77,14 +80,14 @@ changedFile urlrenderer mvar program file _status -} sanityCheck :: FilePath -> Assistant Bool sanityCheck program = do - whileM (liftIO $ haswriter <||> missing) $ do + untilM (liftIO $ nowriter <&&> present) $ do debug [program, "is still being written; waiting"] liftIO $ threadDelaySeconds (Seconds 60) debug [program, "has changed, and seems to be ready to run"] liftIO $ boolSystem program [Param "version"] where - missing = not <$> doesFileExist program - haswriter = not . null + present = doesFileExist program + nowriter = null . filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly]) . map snd3 <$> Lsof.query [program] @@ -95,9 +98,17 @@ handleUpgrade urlrenderer = do -- (For example, other associated files may be being put into -- place.) liftIO $ threadDelaySeconds (Seconds 120) + ifM (liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig) + ( do + debug ["starting automatic upgrade"] + unattendedUpgrade #ifdef WITH_WEBAPP - button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR - void $ addAlert (upgradeReadyAlert button) + , 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 }] #else - noop + , noop #endif + ) diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs index c601c60db2..4079802eca 100644 --- a/Assistant/Types/Alert.hs +++ b/Assistant/Types/Alert.hs @@ -51,7 +51,7 @@ data Alert = Alert , alertIcon :: Maybe AlertIcon , alertCombiner :: Maybe AlertCombiner , alertName :: Maybe AlertName - , alertButton :: Maybe AlertButton + , alertButtons :: [AlertButton] } data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | TheCloud @@ -75,4 +75,5 @@ data AlertButton = AlertButton { buttonLabel :: Text , buttonUrl :: Text , buttonAction :: Maybe (AlertId -> IO ()) + , buttonPrimary :: Bool } diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs new file mode 100644 index 0000000000..8e8e1232d8 --- /dev/null +++ b/Assistant/Upgrade.hs @@ -0,0 +1,61 @@ +{- git-annex assistant upgrading + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Assistant.Upgrade where + +import Assistant.Common +import qualified Annex +import Assistant.Threads.Watcher +import Assistant.Alert +import Assistant.DaemonStatus +import Assistant.NamedThread +import Utility.ThreadScheduler +import Git +import Config.Files + +import Control.Concurrent +import System.Posix (getProcessID, signalProcess, sigTERM) +import System.Process (cwd) + +{- Before the new assistant can be started, have to remove our + - gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also + - a good idea, to avoid fighting when two assistants are running in the + - same repo. + -} +prepUpgrade :: Assistant () +prepUpgrade = do + void $ addAlert upgradingAlert + liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread + liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) + liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile) + +{- Wait for browser to update before terminating this process. -} +postUpgrade :: IO () +postUpgrade = void $ forkIO $ do + threadDelaySeconds (Seconds 120) + signalProcess sigTERM =<< getProcessID + +{- Upgrade without interaction in the webapp. + - + - XXX If the webapp is open, this will make it stop working + - or close, with no more indication why than an alert. + -} +unattendedUpgrade :: Assistant () +unattendedUpgrade = do + prepUpgrade + liftIO . startAssistant =<< liftAnnex (repoLocation <$> Annex.gitRepo) + liftIO postUpgrade + +{- Returns once the assistant has daemonized, but possibly before it's + - listening for web connections. -} +startAssistant :: FilePath -> IO () +startAssistant repo = do + program <- readProgramFile + (_, _, _, pid) <- + createProcess $ + (proc program ["assistant"]) { cwd = Just repo } + void $ checkSuccessProcess pid diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index b47576b6ed..9876d26a83 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -10,10 +10,10 @@ module Assistant.WebApp.Configurators.Local where import Assistant.WebApp.Common -import Assistant.WebApp.OtherRepos import Assistant.WebApp.Gpg import Assistant.WebApp.MakeRemote import Assistant.Sync +import Assistant.Upgrade import Init import qualified Git import qualified Git.Construct diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index d9fc068637..788b5f637d 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -249,6 +249,7 @@ startLocalPairing stage oncancel alert muuid displaysecret secret = do tid <- liftIO myThreadId let selfdestruct = AlertButton { buttonLabel = "Cancel" + , buttonPrimary = True , buttonUrl = urlrender DashboardR , buttonAction = Just $ const $ do oncancel diff --git a/Assistant/WebApp/Configurators/Upgrade.hs b/Assistant/WebApp/Configurators/Upgrade.hs index 1c343d9d46..cfa07f5687 100644 --- a/Assistant/WebApp/Configurators/Upgrade.hs +++ b/Assistant/WebApp/Configurators/Upgrade.hs @@ -13,17 +13,12 @@ import Assistant.WebApp.Common import qualified Annex import Types.Distribution import Assistant.WebApp.OtherRepos -import Assistant.Threads.Watcher -import Assistant.Alert -import Assistant.DaemonStatus -import Assistant.NamedThread -import Utility.ThreadScheduler +import Assistant.Upgrade import Utility.HumanTime import Git +import Config import Data.Time.Clock -import Control.Concurrent -import System.Posix (getProcessID, signalProcess, sigTERM) getConfigStartUpgradeR :: GitAnnexDistribution -> Handler Html getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do @@ -35,28 +30,18 @@ getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do {- Finish upgrade by starting the new assistant in the same repository this - one is running in, and redirecting to it. - - - Before the new assistant can be started, have to remove our - - gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also - - a good idea, to avoid fighting when two assistants are running in the - - same repo. - - - - Note that only the tag that requested this page gets redirected. + - Note that only the browser tab that requested this page gets redirected. - If the user has multiple web browser tabs open to the webapp, - the others will show the upgradingAlert, and keep running until - this process is terminated. -} -getConfigFinishUpgradeR :: Handler Html -getConfigFinishUpgradeR = do - liftAssistant $ void $ addAlert upgradingAlert - liftIO . maybe noop (`throwTo` PauseWatcher) =<< liftAssistant (namedThreadId watchThread) - liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile) - liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile) - reapself `after` startnewprocess +getConfigFinishUpgradeR :: Bool -> Handler Html +getConfigFinishUpgradeR enableautoupgrade = do + when enableautoupgrade $ liftAnnex $ + setConfig (annexConfig "autoupgrade") + (fromAutoUpgrade AutoUpgrade) + liftAssistant prepUpgrade + liftIO postUpgrade `after` startnewprocess where - -- Wait for the redirect to be served to the browser - -- before terminating this process. - reapself = liftIO $ void $ forkIO $ do - threadDelaySeconds (Seconds 120) - signalProcess sigTERM =<< getProcessID startnewprocess = switchToAssistant =<< liftAnnex (repoLocation <$> Annex.gitRepo) diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index 18f900dc6e..d0ded0b228 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -43,6 +43,7 @@ xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do { buttonLabel = "Configure a Jabber account" , buttonUrl = urlrender XMPPConfigR , buttonAction = Just close + , buttonPrimary = True } #else xmppNeeded = return () diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs index 5636ae56c6..00b06afdc6 100644 --- a/Assistant/WebApp/OtherRepos.hs +++ b/Assistant/WebApp/OtherRepos.hs @@ -17,9 +17,9 @@ import qualified Git.Config import Config.Files import qualified Utility.Url as Url import Utility.Yesod +import Assistant.Upgrade import Control.Concurrent -import System.Process (cwd) getRepositorySwitcherR :: Handler Html getRepositorySwitcherR = page "Switch repository" Nothing $ do @@ -63,13 +63,3 @@ switchToAssistant repo = do delayed a = do threadDelay 100000 -- 1/10th of a second a - -{- Returns once the assistant has daemonized, but possibly before it's - - listening for web connections. -} -startAssistant :: FilePath -> IO () -startAssistant repo = do - program <- readProgramFile - (_, _, _, pid) <- - createProcess $ - (proc program ["assistant"]) { cwd = Just repo } - void $ checkSuccessProcess pid diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs index ee7ffb188d..2c33ec86fb 100644 --- a/Assistant/WebApp/SideBar.hs +++ b/Assistant/WebApp/SideBar.hs @@ -50,6 +50,7 @@ sideBarDisplay = do let message = renderAlertMessage alert let messagelines = T.lines message let multiline = length messagelines > 1 + let buttons = zip (alertButtons alert) [1..] $(widgetFile "sidebar/alert") {- Called by client to get a sidebar display. @@ -79,16 +80,20 @@ getCloseAlert :: AlertId -> Handler () getCloseAlert = liftAssistant . removeAlert {- When an alert with a button is clicked on, the button takes us here. -} -getClickAlert :: AlertId -> Handler () -getClickAlert i = do +getClickAlert :: AlertId -> Int -> Handler () +getClickAlert i bnum = do m <- alertMap <$> liftAssistant getDaemonStatus case M.lookup i m of - Just (Alert { alertButton = Just b }) -> do - {- Spawn a thread to run the action while redirecting. -} - case buttonAction b of - Nothing -> noop - Just a -> liftIO $ void $ forkIO $ a i - redirect $ buttonUrl b + Just (Alert { alertButtons = bs }) + | length bs >= bnum -> do + let b = bs !! (bnum - 1) + {- Spawn a thread to run the action + - while redirecting. -} + case buttonAction b of + Nothing -> noop + Just a -> liftIO $ void $ forkIO $ a i + redirect $ buttonUrl b + | otherwise -> redirectBack _ -> redirectBack htmlIcon :: AlertIcon -> Widget diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index 7c5d48d705..937324934a 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -164,6 +164,10 @@ data RemovableDrive = RemovableDrive data RepoKey = RepoKey KeyId | NoRepoKey deriving (Read, Show, Eq, Ord) +instance PathPiece Bool where + toPathPiece = pack . show + fromPathPiece = readish . unpack + instance PathPiece RemovableDrive where toPathPiece = pack . show fromPathPiece = readish . unpack diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index ddde9af6a3..a027ad9387 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -22,7 +22,7 @@ /config/fsck ConfigFsckR GET POST /config/fsck/preferences ConfigFsckPreferencesR POST /config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET -/config/upgrade/finish ConfigFinishUpgradeR GET +/config/upgrade/finish/#Bool ConfigFinishUpgradeR GET /config/addrepository AddRepositoryR GET /config/repository/new NewRepositoryR GET POST @@ -103,7 +103,7 @@ /notifier/repolist/#RepoSelector NotifierRepoListR GET /alert/close/#AlertId CloseAlert GET -/alert/click/#AlertId ClickAlert GET +/alert/click/#AlertId/#Int ClickAlert GET /filebrowser FileBrowserR GET POST /transfer/pause/#Transfer PauseTransferR GET POST diff --git a/templates/sidebar/alert.hamlet b/templates/sidebar/alert.hamlet index 6cade30ba5..90ceb77471 100644 --- a/templates/sidebar/alert.hamlet +++ b/templates/sidebar/alert.hamlet @@ -19,7 +19,8 @@ #{l}
$else #{message} - $maybe button <- alertButton alert + $if not (null buttons)
- - #{buttonLabel button} + $forall (button, bnum) <- buttons + + #{buttonLabel button}