summaryrefslogtreecommitdiff
path: root/Command/WebApp.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-01-15 13:34:59 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-01-15 13:34:59 -0400
commitb236c46dbb20cfbb42201b7cccdaa153b7bd2ed1 (patch)
tree59915ff94b6cb0bb1df8858f30e06b5408af8b44 /Command/WebApp.hs
parentfd9d5f0d9c3de99c53ba12c85e6c985baeb38901 (diff)
webapp: Now always logs to .git/annex/daemon.log
It used to not log to daemon.log when a repository was first created, and when starting the webapp. Now both do. Redirecting stdout and stderr to the log is tricky when starting the webapp, because the web browser may want to communicate with the user. (Either a console web browser, or web.browser = echo) This is handled by restoring the original fds when running the browser.
Diffstat (limited to 'Command/WebApp.hs')
-rw-r--r--Command/WebApp.hs46
1 files changed, 24 insertions, 22 deletions
diff --git a/Command/WebApp.hs b/Command/WebApp.hs
index 581d6d4dd..20a2ecdbe 100644
--- a/Command/WebApp.hs
+++ b/Command/WebApp.hs
@@ -16,7 +16,7 @@ import Assistant.Threads.WebApp
import Assistant.WebApp
import Assistant.Install
import Utility.WebApp
-import Utility.Daemon (checkDaemon, lockPidFile)
+import Utility.Daemon (checkDaemon)
import Init
import qualified Git
import qualified Git.Config
@@ -27,6 +27,7 @@ import Locations.UserConfig
import System.Posix.Directory
import Control.Concurrent
import Control.Concurrent.STM
+import System.Process (env, std_out, std_err)
def :: [Command]
def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $
@@ -48,9 +49,10 @@ start' allowauto = do
browser <- fromRepo webBrowser
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
ifM (checkpid <&&> checkshim f)
- ( liftIO $ openBrowser browser f
- , startDaemon True True $ Just $
- const $ openBrowser browser
+ ( liftIO $ openBrowser browser f Nothing Nothing
+ , startDaemon True True $ Just $
+ \origout origerr _url htmlshim ->
+ openBrowser browser htmlshim origout origerr
)
auto
| allowauto = liftIO startNoRepo
@@ -117,30 +119,30 @@ firstRun = do
takeMVar v
mainthread v _url htmlshim = do
browser <- maybe Nothing webBrowser <$> Git.Config.global
- openBrowser browser htmlshim
+ openBrowser browser htmlshim Nothing Nothing
_wait <- takeMVar v
state <- Annex.new =<< Git.CurrentRepo.get
- Annex.eval state $ do
- dummydaemonize
- startAssistant True id $ Just $ sendurlback v
- sendurlback v url _htmlshim = putMVar v url
-
- {- Set up the pid file in the new repo. -}
- dummydaemonize = liftIO . lockPidFile =<< fromRepo gitAnnexPidFile
-
-openBrowser :: Maybe FilePath -> FilePath -> IO ()
-openBrowser cmd htmlshim = go $ maybe runBrowser runCustomBrowser cmd
+ Annex.eval state $
+ startDaemon True True $ Just $ sendurlback v
+ sendurlback v _origout _origerr url _htmlshim = putMVar v url
+
+openBrowser :: Maybe FilePath -> FilePath -> Maybe Handle -> Maybe Handle -> IO ()
+openBrowser cmd htmlshim outh errh = do
+ hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
+ environ <- cleanEnvironment
+ (_, _, _, pid) <- createProcess p
+ { env = environ
+ , std_out = maybe Inherit UseHandle outh
+ , std_err = maybe Inherit UseHandle errh
+ }
+ exitcode <- waitForProcess pid
+ unless (exitcode == ExitSuccess) $
+ hPutStrLn (fromMaybe stderr errh) "failed to start web browser"
where
url = fileUrl htmlshim
- go a = do
- putStrLn ""
- putStrLn $ "Launching web browser on " ++ url
- env <- cleanEnvironment
- unlessM (a url env) $
- error $ "failed to start web browser"
- runCustomBrowser c u = boolSystemEnv c [Param u]
+ p = proc (fromMaybe browserCommand cmd) [htmlshim]
{- web.browser is a generic git config setting for a web browser program -}
webBrowser :: Git.Repo -> Maybe FilePath