diff options
| -rw-r--r-- | Assistant.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 31 | ||||
| -rw-r--r-- | Command/WebApp.hs | 58 | ||||
| -rw-r--r-- | GitAnnex.hs | 6 | ||||
| -rw-r--r-- | Locations.hs | 5 | ||||
| -rw-r--r-- | Utility/Daemon.hs | 43 |
6 files changed, 122 insertions, 23 deletions
diff --git a/Assistant.hs b/Assistant.hs index de996aa74..c867529fd 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -152,7 +152,7 @@ startDaemon assistant foreground , mountWatcherThread st dstatus scanremotes , transferScannerThread st scanremotes transferqueue #ifdef WITH_WEBAPP - , webAppThread dstatus + , webAppThread st dstatus #endif , watchThread st dstatus transferqueue changechan ] diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 1d9d3cc2f..f3f13c5a0 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -10,10 +10,12 @@ module Assistant.Threads.WebApp where import Assistant.Common +import Assistant.ThreadedMonad import Assistant.DaemonStatus import Utility.WebApp import Yesod +import Network.Socket (PortNumber) data WebApp = WebApp DaemonStatusHandle @@ -30,14 +32,33 @@ getHomeR = defaultLayout [whamlet|Hello, World<p><a href=@{ConfigR}>config|] getConfigR :: Handler RepHtml getConfigR = defaultLayout [whamlet|<a href=@{HomeR}>main|] -webAppThread :: DaemonStatusHandle -> IO () -webAppThread dstatus = do +webAppThread :: ThreadState -> DaemonStatusHandle -> IO () +webAppThread st dstatus = do app <- toWaiApp (WebApp dstatus) app' <- ifM debugEnabled ( return $ httpDebugLogger app , return app ) - runWebApp app' browser + runWebApp app' $ \p -> runThreadState st $ writeHtmlShim p + +{- Creates a html shim file that's used to redirect into the webapp. -} +writeHtmlShim :: PortNumber -> Annex () +writeHtmlShim port = do + htmlshim <- fromRepo gitAnnexHtmlShim + liftIO $ writeFile htmlshim $ genHtmlShim port + +{- TODO: generate this static file using Yesod. -} +genHtmlShim :: PortNumber -> String +genHtmlShim port = unlines + [ "<html>" + , "<head>" + , "<meta http-equiv=\"refresh\" content=\"0; URL=" ++ url ++ "\">" + , "</head>" + , "<body>" + , "<p>" + , "<a href=\"" ++ url ++ "\">Starting webapp...</a>" + , "</p>" + , "</body>" + ] where - browser p = void $ - runBrowser $ "http://" ++ localhost ++ ":" ++ show p + url = "http://localhost:" ++ show port ++ "/" diff --git a/Command/WebApp.hs b/Command/WebApp.hs new file mode 100644 index 000000000..616a6512a --- /dev/null +++ b/Command/WebApp.hs @@ -0,0 +1,58 @@ +{- git-annex webapp launcher + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.WebApp where + +import Common.Annex +import Command +import Assistant +import Utility.WebApp +import Utility.Daemon +import qualified Annex + +import Control.Concurrent +import System.Posix.Process + +def :: [Command] +def = [command "webapp" paramNothing seek "launch webapp"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = notBareRepo $ do + r <- checkpid + when (r == Nothing) $ + startassistant + f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim + let url = "file://" ++ f + ifM (liftIO $ runBrowser url) + ( stop + , error $ "failed to start web browser on url " ++ url + ) + where + checkpid = do + pidfile <- fromRepo gitAnnexPidFile + liftIO $ checkDaemon pidfile + startassistant = do + {- Fork a separate process to run the assistant, + - with a copy of the Annex state. -} + state <- Annex.getState id + liftIO $ void $ forkProcess $ + Annex.eval state $ startDaemon True False + waitdaemon (100 :: Int) + waitdaemon 0 = error "failed to start git-annex assistant" + waitdaemon n = do + r <- checkpid + case r of + Just _ -> return () + Nothing -> do + liftIO $ + threadDelay 100000 -- 0.1 seconds + + +waitdaemon (n - 1) diff --git a/GitAnnex.hs b/GitAnnex.hs index 7b1fa5986..ce7a41a40 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -63,6 +63,9 @@ import qualified Command.Version #ifdef WITH_ASSISTANT import qualified Command.Watch import qualified Command.Assistant +#ifdef WITH_WEBAPP +import qualified Command.WebApp +#endif #endif cmds :: [Command] @@ -108,6 +111,9 @@ cmds = concat #ifdef WITH_ASSISTANT , Command.Watch.def , Command.Assistant.def +#ifdef WITH_WEBAPP + , Command.WebApp.def +#endif #endif ] diff --git a/Locations.hs b/Locations.hs index 082a72a50..cbd1e11ae 100644 --- a/Locations.hs +++ b/Locations.hs @@ -27,6 +27,7 @@ module Locations ( gitAnnexPidFile, gitAnnexDaemonStatusFile, gitAnnexLogFile, + gitAnnexHtmlShim, gitAnnexSshDir, gitAnnexRemotesDir, isLinkToAnnex, @@ -166,6 +167,10 @@ gitAnnexDaemonStatusFile r = gitAnnexDir r </> "daemon.status" gitAnnexLogFile :: Git.Repo -> FilePath gitAnnexLogFile r = gitAnnexDir r </> "daemon.log" +{- Html shim file used to launch the webapp. -} +gitAnnexHtmlShim :: Git.Repo -> FilePath +gitAnnexHtmlShim r = gitAnnexDir r </> "webapp.html" + {- .git/annex/ssh/ is used for ssh connection caching -} gitAnnexSshDir :: Git.Repo -> FilePath gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh" diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index f36a761d0..8aa70d155 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -62,24 +62,33 @@ lockPidFile onfailure file = do where newfile = file ++ ".new" -{- Stops the daemon. +{- Checks if the daemon is running, by checking that the pid file + - is locked by the same process that is listed in the pid file. - - - The pid file is used to get the daemon's pid. - - - - To guard against a stale pid, check the lock of the pid file, - - and compare the process that has it locked with the file content. - -} -stopDaemon :: FilePath -> IO () -stopDaemon pidfile = do - fd <- openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags - locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) - p <- readish <$> readFile pidfile - case (locked, p) of - (Nothing, _) -> noop - (_, Nothing) -> noop - (Just (pid, _), Just pid') - | pid == pid' -> signalProcess sigTERM pid - | otherwise -> error $ + - If it's running, returns its pid. -} +checkDaemon :: FilePath -> IO (Maybe ProcessID) +checkDaemon pidfile = do + v <- catchMaybeIO $ + openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags + case v of + Just fd -> do + locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) + p <- readish <$> readFile pidfile + return $ check locked p + Nothing -> return Nothing + where + check Nothing _ = Nothing + check _ Nothing = Nothing + check (Just (pid, _)) (Just pid') + | pid == pid' = Just pid + | otherwise = error $ "stale pid in " ++ pidfile ++ " (got " ++ show pid' ++ "; expected" ++ show pid ++ " )" + +{- Stops the daemon, safely. -} +stopDaemon :: FilePath -> IO () +stopDaemon pidfile = go =<< checkDaemon pidfile + where + go Nothing = noop + go (Just pid) = signalProcess sigTERM pid |