From 1ffef3ad75e51b7f66c4ffdd0935a0495042e5ae Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 25 Jul 2012 23:13:01 -0400 Subject: [PATCH] git annex webapp now opens a browser to the webapp Also, starts the assistant if it wasn't already running. --- Assistant.hs | 2 +- Assistant/Threads/WebApp.hs | 31 ++++++++++++++++---- Command/WebApp.hs | 58 +++++++++++++++++++++++++++++++++++++ GitAnnex.hs | 6 ++++ Locations.hs | 5 ++++ Utility/Daemon.hs | 43 ++++++++++++++++----------- 6 files changed, 122 insertions(+), 23 deletions(-) create mode 100644 Command/WebApp.hs diff --git a/Assistant.hs b/Assistant.hs index de996aa741..c867529fdf 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 1d9d3cc2fc..f3f13c5a09 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

config|] getConfigR :: Handler RepHtml getConfigR = defaultLayout [whamlet|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 + [ "" + , "" + , "" + , "" + , "" + , "

" + , "Starting webapp..." + , "

" + , "" + ] 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 0000000000..616a6512a8 --- /dev/null +++ b/Command/WebApp.hs @@ -0,0 +1,58 @@ +{- git-annex webapp launcher + - + - Copyright 2012 Joey Hess + - + - 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 7b1fa59868..ce7a41a40f 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 082a72a506..cbd1e11ae0 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 f36a761d00..8aa70d155c 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