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 ()
+{- Starts the daemon. If the daemon is run in the foreground, once it's
-startDaemon assistant foreground webappwaiter
+ - running, can start the browser.
-	| foreground = do
+ -
-		showStart (if assistant then "assistant" else "watch") "."
+ - startbrowser is passed the url and html shim file, as well as the original
-		liftIO . Utility.Daemon.lockPidFile =<< fromRepo gitAnnexPidFile
+ - stdout and stderr descriptors. -}
-		go id
+startDaemon :: Bool -> Bool -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
-	| otherwise = do
+startDaemon assistant foreground startbrowser = do
-		logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile
 	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
+	start daemonize webappwaiter = withThreadState $ \st -> do
-
-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
+			flip runAssistant (go webappwaiter) 
-  where
+				=<< newAssistantData st dstatus
-	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)

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
+		Annex.eval state $
-			dummydaemonize
+			startDaemon True True $ Just $ sendurlback v
-			startAssistant True id $ Just $ sendurlback v
+	sendurlback v _origout _origerr url _htmlshim = putMVar v url
-	sendurlback v url _htmlshim = putMVar v url
 
-	{- Set up the pid file in the new repo. -}
+openBrowser :: Maybe FilePath -> FilePath -> Maybe Handle -> Maybe Handle -> IO ()
-	dummydaemonize = liftIO . lockPidFile =<< fromRepo gitAnnexPidFile
+openBrowser cmd htmlshim outh errh = do
-
+	hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
-openBrowser :: Maybe FilePath -> FilePath -> IO ()
+	environ <- cleanEnvironment
-openBrowser cmd htmlshim = go $ maybe runBrowser runCustomBrowser cmd
+	(_, _, _, 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
+	p = proc (fromMaybe browserCommand cmd) [htmlshim]
-		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]
 
 {- web.browser is a generic git config setting for a web browser program -}
 webBrowser :: Git.Repo -> Maybe FilePath

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
+		redir nullfd stdInput
-		mapM_ (redir logfd) [stdOutput, stdError]
+		redirLog logfd
-		closeFd 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. -}

Utility/WebApp.hs

@@ -40,16 +40,12 @@ import Control.Concurrent
 localhost :: String
 localhost = "localhost"
 
-{- Runs a web browser on a given url.
+{- Command to use to run a web browser. -}
- -
+browserCommand :: FilePath
- - 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
 #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