cd076cd085
That is a legal url, but parseUrl parses it to "/c:/path" which is not a valid path on Windows. So as a workaround, use parseURIPortable everywhere, which removes the leading slash when run on windows. Note that if an url is parsed like this and then serialized back to a string, it will be different from the input. Which could potentially be a problem, but is probably not in practice. An alternative way to do it would be to have an uriPathPortable that fixes up the path after parsing. But it would be harder to make sure that is used everywhere, since uriPath is also used when constructing an URI. It's also worth noting that System.FilePath.normalize "/c:/path" yields "c:/path". The reason I didn't use it is that it also may change "/" to "\" in the path and I wanted to keep the url changes minimal. Also noticed that convertToWindowsNativeNamespace handles "/c:/path" the same as "c:/path". Sponsored-By: the NIH-funded NICEMAN (ReproNim TR&D3) project
118 lines
3.5 KiB
Haskell
118 lines
3.5 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 Utility.RawFilePath as R
|
|
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 . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile)
|
|
liftIO . removeWhenExistsWith R.removeLink =<< 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 (toRawFilePath repo)
|
|
waiturl $ fromRawFilePath $ 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 parseURIPortable 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
|