git annex webapp now opens a browser to the webapp

Also, starts the assistant if it wasn't already running.
author: Joey Hess <joey@kitenet.net> 2012-07-25 23:13:01 -0400
committer: Joey Hess <joey@kitenet.net> 2012-07-25 23:13:01 -0400
commit: 1ffef3ad75e51b7f66c4ffdd0935a0495042e5ae (patch)
tree: 202fa2e776f76c1decaab7a6839688886bbcc490
parent: e6ce54de82c19999fb5adcd5fd1ea4001fd2059e (diff)
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
author	Joey Hess <joey@kitenet.net>	2012-07-25 23:13:01 -0400
committer	Joey Hess <joey@kitenet.net>	2012-07-25 23:13:01 -0400
commit	1ffef3ad75e51b7f66c4ffdd0935a0495042e5ae (patch)
tree	202fa2e776f76c1decaab7a6839688886bbcc490
parent	e6ce54de82c19999fb5adcd5fd1ea4001fd2059e (diff)