replace horrible old daemon restart code with new method

Assistant/Restart.hs

@@ -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

Assistant/Upgrade.hs

@@ -8,58 +8,30 @@
 module Assistant.Upgrade where
 
 import Assistant.Common
+import Assistant.Restart
 import qualified Annex
-import Assistant.Threads.Watcher
 import Assistant.Alert
 import Assistant.DaemonStatus
-import Assistant.NamedThread
-import Utility.ThreadScheduler
-import Utility.NotificationBroadcaster
 import Utility.Url
 import Utility.Env
-import Git
-import qualified Git.Construct
-import qualified Git.Config
-import Config.Files
 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. -}
 unattendedUpgrade :: Assistant ()
 unattendedUpgrade = do
 	prepUpgrade
-	url <- liftIO . newAssistantUrl
-		=<< liftAnnex (repoLocation <$> Annex.gitRepo)
+	url <- runRestart
 	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 = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig
 
@@ -68,37 +40,3 @@ checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv
 
 upgradedEnv :: String
 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

Assistant/WebApp/Configurators/Local.hs

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

Assistant/WebApp/Configurators/Upgrade.hs

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

Assistant/WebApp/Control.hs

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

Assistant/WebApp/OtherRepos.hs

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

templates/control/restarting.hamlet

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