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.

6 files changed, 75 insertions, 56 deletions

diff --git a/Assistant.hs b/Assistant.hs
index e529df487..06f8d64e5 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -163,28 +163,40 @@ type NamedThread = IO () -> IO (String, IO ())
 stopDaemon :: Annex ()
 stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
 
-startDaemon :: Bool -> Bool -> Maybe (String -> FilePath -> IO ()) -> Annex ()
-startDaemon assistant foreground webappwaiter
-	| foreground = do
-		showStart (if assistant then "assistant" else "watch") "."
-		liftIO . Utility.Daemon.lockPidFile =<< fromRepo gitAnnexPidFile
-		go id
-	| otherwise = do
-		logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile
-		pidfile <- fromRepo gitAnnexPidFile
-		go $ Utility.Daemon.daemonize logfd (Just pidfile) False
+{- Starts the daemon. If the daemon is run in the foreground, once it's
+ - running, can start the browser.
+ -
+ - startbrowser is passed the url and html shim file, as well as the original
+ - stdout and stderr descriptors. -}
+startDaemon :: Bool -> Bool -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
+startDaemon assistant foreground startbrowser = do
+	pidfile <- fromRepo gitAnnexPidFile
+	logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile
+	if foreground
+		then do
+			liftIO $ Utility.Daemon.lockPidFile pidfile
+			origout <- liftIO $ catchMaybeIO $ 
+				fdToHandle =<< dup stdOutput
+			origerr <- liftIO $ catchMaybeIO $ 
+				fdToHandle =<< dup stdError
+			liftIO $ Utility.Daemon.redirLog logfd
+			showStart (if assistant then "assistant" else "watch") "."
+			start id $ 
+				case startbrowser of
+					Nothing -> Nothing
+					Just a -> Just $ a origout origerr
+		else
+			start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
   where
-	go d = startAssistant assistant d webappwaiter
+	start daemonize webappwaiter = withThreadState $ \st -> do
+		checkCanWatch
+		when assistant $ checkEnvironment
+		dstatus <- startDaemonStatus
+		liftIO $ daemonize $
+			flip runAssistant (go webappwaiter) 
+				=<< newAssistantData st dstatus
 
-startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO ()) -> Annex ()
-startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
-	checkCanWatch
-	when assistant $ checkEnvironment
-	dstatus <- startDaemonStatus
-	liftIO $ daemonize $
-		flip runAssistant go =<< newAssistantData st dstatus
-  where
-	go = do
+	go webappwaiter = do
 		d <- getAssistant id
 #ifdef WITH_WEBAPP
 		urlrenderer <- liftIO newUrlRenderer
@@ -216,6 +228,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 			, assist $ glacierThread
 			, watch $ watchThread
 			]
+	
 		liftIO waitForTermination
 
 	watch a = (True, a)
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 316f1fbaf..f2702ec35 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -97,6 +97,7 @@ startupScan scanner = do
 		void $ liftIO $ cleanup
 		
 		liftAnnex $ showAction "started"
+		liftIO $ putStrLn ""
 		
 		modifyDaemonStatus_ $ \s -> s { scanComplete = True }
 
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
diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index 16245268e..185ea3e68 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -34,16 +34,22 @@ daemonize logfd pidfile changedirectory a = do
 		when changedirectory $
 			setCurrentDirectory "/"
 		nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
-		_ <- redir nullfd stdInput
-		mapM_ (redir logfd) [stdOutput, stdError]
-		closeFd logfd
+		redir nullfd stdInput
+		redirLog logfd
 		a
 		out
-	redir newh h = do
-		closeFd h
-		dupTo newh h
 	out = exitImmediately ExitSuccess
 
+redirLog :: Fd -> IO ()
+redirLog logfd = do
+	mapM_ (redir logfd) [stdOutput, stdError]
+	closeFd logfd
+
+redir :: Fd -> Fd -> IO ()
+redir newh h = do
+	closeFd h
+	void $ dupTo newh h
+
 {- Locks the pid file, with an exclusive, non-blocking lock.
  - Writes the pid to the file, fully atomically.
  - Fails if the pid file is already locked by another process. -}
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
index 51300c9cf..c6aae9db5 100644
--- a/Utility/WebApp.hs
+++ b/Utility/WebApp.hs
@@ -40,16 +40,12 @@ import Control.Concurrent
 localhost :: String
 localhost = "localhost"
 
-{- Runs a web browser on a given url.
- -
- - Note: The url *will* be visible to an attacker. -}
-runBrowser :: String -> (Maybe [(String, String)]) -> IO Bool
-runBrowser url env = boolSystemEnv cmd [Param url] env
-  where
+{- Command to use to run a web browser. -}
+browserCommand :: FilePath
 #ifdef darwin_HOST_OS
-	cmd = "open"
+browserCommand = "open"
 #else
-	cmd = "xdg-open"
+browserCommand = "xdg-open"
 #endif
 
 {- Binds to a socket on localhost, and runs a webapp on it.
diff --git a/debian/changelog b/debian/changelog
index 67c955fea..344081fa3 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -4,6 +4,7 @@ git-annex (3.20130115) UNRELEASED; urgency=low
     variable quoting in different versions of shakespeare-js.
   * webapp: Avoid an error if a transfer is stopped just as it finishes.
     Closes: #698184 
+  * webapp: Now always logs to .git/annex/daemon.log.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 14 Jan 2013 18:35:01 -0400