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.

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
+{- 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
-		go $ Utility.Daemon.daemonize logfd (Just pidfile) False
+	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
-
-startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO ()) -> Annex ()
-startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
+	start daemonize webappwaiter = withThreadState $ \st -> do
 		checkCanWatch
 		when assistant $ checkEnvironment
 		dstatus <- startDaemonStatus
 		liftIO $ daemonize $
-		flip runAssistant go =<< newAssistantData st dstatus
-  where
-	go = do
+			flip runAssistant (go webappwaiter) 
+				=<< newAssistantData st dstatus
+
+	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)

Assistant/Threads/Watcher.hs

@@ -97,6 +97,7 @@ startupScan scanner = do
 		void $ liftIO $ cleanup
 		
 		liftAnnex $ showAction "started"
+		liftIO $ putStrLn ""
 		
 		modifyDaemonStatus_ $ \s -> s { scanComplete = True }
 

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 
+			( liftIO $ openBrowser browser f Nothing Nothing
 			, startDaemon True True $ Just $ 
-				const $ openBrowser browser
+				\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
+		Annex.eval state $
+			startDaemon True True $ Just $ sendurlback v
+	sendurlback v _origout _origerr 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
+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

Utility/Daemon.hs

@@ -34,15 +34,21 @@ 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
+	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
-		dupTo newh h
-	out = exitImmediately ExitSuccess
+	void $ dupTo newh h
 
 {- Locks the pid file, with an exclusive, non-blocking lock.
  - Writes the pid to the file, fully atomically.

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.

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