replace horrible old daemon restart code with new method

This commit is contained in:
Joey Hess 2013-11-23 15:50:17 -04:00
parent cf1f7eb185
commit b1a89c448a
7 changed files with 107 additions and 93 deletions

86
Assistant/Restart.hs Normal file
View file

@ -0,0 +1,86 @@
{- git-annex assistant restarting
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Assistant.Restart where
import Assistant.Common
import Assistant.Threads.Watcher
import Assistant.DaemonStatus
import Assistant.NamedThread
import Utility.ThreadScheduler
import Utility.NotificationBroadcaster
import Utility.Url
import qualified Git.Construct
import qualified Git.Config
import Config.Files
import qualified Annex
import qualified Git
import Control.Concurrent
import System.Posix (getProcessID, signalProcess, sigTERM)
import System.Process (cwd)
{- Before the assistant can be restarted, 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.
-}
prepRestart :: Assistant ()
prepRestart = do
liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
{- To finish a restart, send a global redirect to the new url
- to any web browsers that are displaying the webapp.
-
- Wait for browser to update before terminating this process. -}
postRestart :: URLString -> Assistant ()
postRestart url = do
modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
void $ liftIO $ forkIO $ do
threadDelaySeconds (Seconds 120)
signalProcess sigTERM =<< getProcessID
runRestart :: Assistant URLString
runRestart = liftIO . newAssistantUrl
=<< liftAnnex (Git.repoLocation <$> Annex.gitRepo)
{- Starts up the assistant in the repository, and waits for it to create
- a gitAnnexUrlFile. Waits for the assistant to be up and listening for
- connections by testing the url. -}
newAssistantUrl :: FilePath -> IO URLString
newAssistantUrl repo = do
startAssistant repo
geturl
where
geturl = do
r <- Git.Config.read =<< Git.Construct.fromPath repo
waiturl $ gitAnnexUrlFile r
waiturl urlfile = do
v <- tryIO $ readFile urlfile
case v of
Left _ -> delayed $ waiturl urlfile
Right url -> ifM (listening url)
( return url
, delayed $ waiturl urlfile
)
listening url = catchBoolIO $ fst <$> exists url [] Nothing
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

View file

@ -8,58 +8,30 @@
module Assistant.Upgrade where module Assistant.Upgrade where
import Assistant.Common import Assistant.Common
import Assistant.Restart
import qualified Annex import qualified Annex
import Assistant.Threads.Watcher
import Assistant.Alert import Assistant.Alert
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.NamedThread
import Utility.ThreadScheduler
import Utility.NotificationBroadcaster
import Utility.Url import Utility.Url
import Utility.Env import Utility.Env
import Git
import qualified Git.Construct
import qualified Git.Config
import Config.Files
import Types.Distribution import Types.Distribution
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)
void $ liftIO $ setEnv upgradedEnv "1" True
{- To finish an upgrade, send a global redirect to the new url
- to any web browsers that are displaying the webapp.
-
- Wait for browser to update before terminating this process. -}
postUpgrade :: URLString -> Assistant ()
postUpgrade url = do
modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
void $ liftIO $ forkIO $ do
threadDelaySeconds (Seconds 120)
signalProcess sigTERM =<< getProcessID
{- Upgrade without interaction in the webapp. -} {- Upgrade without interaction in the webapp. -}
unattendedUpgrade :: Assistant () unattendedUpgrade :: Assistant ()
unattendedUpgrade = do unattendedUpgrade = do
prepUpgrade prepUpgrade
url <- liftIO . newAssistantUrl url <- runRestart
=<< liftAnnex (repoLocation <$> Annex.gitRepo)
postUpgrade url postUpgrade url
prepUpgrade :: Assistant ()
prepUpgrade = do
void $ addAlert upgradingAlert
void $ liftIO $ setEnv upgradedEnv "1" True
prepRestart
postUpgrade :: URLString -> Assistant ()
postUpgrade = postRestart
autoUpgradeEnabled :: Assistant Bool autoUpgradeEnabled :: Assistant Bool
autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig
@ -68,37 +40,3 @@ checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv
upgradedEnv :: String upgradedEnv :: String
upgradedEnv = "GIT_ANNEX_UPGRADED" upgradedEnv = "GIT_ANNEX_UPGRADED"
{- Starts up the assistant in the repository, and waits for it to create
- a gitAnnexUrlFile. Waits for the assistant to be up and listening for
- connections by testing the url. -}
newAssistantUrl :: FilePath -> IO URLString
newAssistantUrl repo = do
startAssistant repo
geturl
where
geturl = do
r <- Git.Config.read =<< Git.Construct.fromPath repo
waiturl $ gitAnnexUrlFile r
waiturl urlfile = do
v <- tryIO $ readFile urlfile
case v of
Left _ -> delayed $ waiturl urlfile
Right url -> ifM (listening url)
( return url
, delayed $ waiturl urlfile
)
listening url = catchBoolIO $ fst <$> exists url [] Nothing
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

View file

@ -13,7 +13,7 @@ import Assistant.WebApp.Common
import Assistant.WebApp.Gpg import Assistant.WebApp.Gpg
import Assistant.WebApp.MakeRemote import Assistant.WebApp.MakeRemote
import Assistant.Sync import Assistant.Sync
import Assistant.Upgrade import Assistant.Restart
import Init import Init
import qualified Git import qualified Git
import qualified Git.Construct import qualified Git.Construct

View file

@ -10,11 +10,10 @@
module Assistant.WebApp.Configurators.Upgrade where module Assistant.WebApp.Configurators.Upgrade where
import Assistant.WebApp.Common import Assistant.WebApp.Common
import qualified Annex
import Types.Distribution import Types.Distribution
import Assistant.Upgrade import Assistant.Upgrade
import Assistant.Restart
import Utility.HumanTime import Utility.HumanTime
import Git
import Config import Config
import Data.Time.Clock import Data.Time.Clock
@ -31,8 +30,7 @@ getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do
getConfigFinishUpgradeR :: Handler Html getConfigFinishUpgradeR :: Handler Html
getConfigFinishUpgradeR = do getConfigFinishUpgradeR = do
liftAssistant prepUpgrade liftAssistant prepUpgrade
url <- liftIO . newAssistantUrl url <- liftAssistant runRestart
=<< liftAnnex (repoLocation <$> Annex.gitRepo)
liftAssistant $ postUpgrade url liftAssistant $ postUpgrade url
redirect url redirect url

View file

@ -10,11 +10,11 @@
module Assistant.WebApp.Control where module Assistant.WebApp.Control where
import Assistant.WebApp.Common import Assistant.WebApp.Common
import Config.Files
import Utility.LogFile import Utility.LogFile
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.Alert import Assistant.Alert
import Assistant.TransferSlots import Assistant.TransferSlots
import Assistant.Restart
import Control.Concurrent import Control.Concurrent
import System.Posix (getProcessID, signalProcess, sigTERM) import System.Posix (getProcessID, signalProcess, sigTERM)
@ -44,18 +44,12 @@ getShutdownConfirmedR = do
signalProcess sigTERM =<< getProcessID signalProcess sigTERM =<< getProcessID
$(widgetFile "control/shutdownconfirmed") $(widgetFile "control/shutdownconfirmed")
{- Quite a hack, and doesn't redirect the browser window. -}
getRestartR :: Handler Html getRestartR :: Handler Html
getRestartR = page "Restarting" Nothing $ do getRestartR = do
void $ liftIO $ forkIO $ do liftAssistant prepRestart
threadDelay 2000000 url <- liftAssistant runRestart
program <- readProgramFile liftAssistant $ postRestart url
unlessM (boolSystem "sh" [Param "-c", Param $ restartcommand program]) $ redirect url
error "restart failed"
$(widgetFile "control/restarting")
where
restartcommand program = program ++ " assistant --stop; exec " ++
program ++ " webapp"
getRestartThreadR :: ThreadName -> Handler () getRestartThreadR :: ThreadName -> Handler ()
getRestartThreadR name = do getRestartThreadR name = do

View file

@ -14,7 +14,7 @@ import Assistant.WebApp.Types
import Assistant.WebApp.Page import Assistant.WebApp.Page
import Config.Files import Config.Files
import Utility.Yesod import Utility.Yesod
import Assistant.Upgrade import Assistant.Restart
getRepositorySwitcherR :: Handler Html getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do getRepositorySwitcherR = page "Switch repository" Nothing $ do

View file

@ -1,2 +0,0 @@
<div .span9 .hero-unit>
Restarting...