438dbe3b66
This handles all sites where checkSuccessProcess/ignoreFailureProcess is used, except for one: Git.Command.pipeReadLazy That one will be significantly more work to convert to bracketing. (Also skipped Command.Assistant.autoStart, but it does not need to shut down the processes it started on exception because they are git-annex assistant daemons..) forceSuccessProcess is done, except for createProcessSuccess. All call sites of createProcessSuccess will need to be converted to bracketing. (process pools still todo also)
117 lines
3.4 KiB
Haskell
117 lines
3.4 KiB
Haskell
{- git-annex assistant restarting
|
|
-
|
|
- Copyright 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
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 Utility.PID
|
|
import qualified Git.Construct
|
|
import qualified Git.Config
|
|
import qualified Annex
|
|
import qualified Git
|
|
import Annex.Path
|
|
|
|
import Control.Concurrent
|
|
#ifndef mingw32_HOST_OS
|
|
import System.Posix (signalProcess, sigTERM)
|
|
#else
|
|
import System.Win32.Process (terminateProcessById)
|
|
#endif
|
|
import Network.URI
|
|
|
|
{- 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)
|
|
terminateSelf
|
|
|
|
terminateSelf :: IO ()
|
|
terminateSelf =
|
|
#ifndef mingw32_HOST_OS
|
|
signalProcess sigTERM =<< getPID
|
|
#else
|
|
terminateProcessById =<< getPID
|
|
#endif
|
|
|
|
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 (assistantListening url)
|
|
( return url
|
|
, delayed $ waiturl urlfile
|
|
)
|
|
delayed a = do
|
|
threadDelay 100000 -- 1/10th of a second
|
|
a
|
|
|
|
{- Checks if the assistant is listening on an url.
|
|
-
|
|
- Always checks http, because https with self-signed cert is problematic.
|
|
- warp-tls listens to http, in order to show an error page, so this works.
|
|
-}
|
|
assistantListening :: URLString -> IO Bool
|
|
assistantListening url = catchBoolIO $ do
|
|
uo <- defUrlOptions
|
|
(== Right True) <$> exists url' uo
|
|
where
|
|
url' = case parseURI url of
|
|
Nothing -> url
|
|
Just uri -> show $ uri
|
|
{ uriScheme = "http:"
|
|
}
|
|
|
|
{- Does not wait for assistant to be listening for web connections.
|
|
-
|
|
- On windows, the assistant does not daemonize, which is why the forkIO is
|
|
- done.
|
|
-}
|
|
startAssistant :: FilePath -> IO ()
|
|
startAssistant repo = void $ forkIO $ do
|
|
program <- programPath
|
|
let p = (proc program ["assistant"]) { cwd = Just repo }
|
|
withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid
|