diff options
| -rw-r--r-- | Assistant.hs | 53 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 1 | ||||
| -rw-r--r-- | Command/WebApp.hs | 46 | ||||
| -rw-r--r-- | Utility/Daemon.hs | 18 | ||||
| -rw-r--r-- | Utility/WebApp.hs | 12 | ||||
| -rw-r--r-- | debian/changelog | 1 |
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 |