e872c3f648
This avoids some small overhead by only running the check once per command; it also ensures that, even if the command doesn't find anything to run on, it still fails to run when in a bare repo.
150 lines
4.5 KiB
Haskell
150 lines
4.5 KiB
Haskell
{- git-annex webapp launcher
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.WebApp where
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import Assistant
|
|
import Assistant.Common
|
|
import Assistant.NamedThread
|
|
import Assistant.Threads.WebApp
|
|
import Assistant.WebApp
|
|
import Assistant.Install
|
|
import Utility.WebApp
|
|
import Utility.Daemon (checkDaemon, lockPidFile)
|
|
import Init
|
|
import qualified Git
|
|
import qualified Git.Config
|
|
import qualified Git.CurrentRepo
|
|
import qualified Annex
|
|
import Locations.UserConfig
|
|
|
|
import System.Posix.Directory
|
|
import Control.Concurrent
|
|
import Control.Concurrent.STM
|
|
|
|
def :: [Command]
|
|
def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $
|
|
command "webapp" paramNothing seek "launch webapp"]
|
|
|
|
seek :: [CommandSeek]
|
|
seek = [withNothing start]
|
|
|
|
start :: CommandStart
|
|
start = start' True
|
|
|
|
start' :: Bool -> CommandStart
|
|
start' allowauto = do
|
|
liftIO $ ensureInstalled
|
|
ifM isInitialized ( go , auto )
|
|
stop
|
|
where
|
|
go = do
|
|
browser <- fromRepo webBrowser
|
|
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
|
|
ifM (checkpid <&&> checkshim f)
|
|
( liftIO $ openBrowser browser f
|
|
, startDaemon True True $ Just $
|
|
const $ openBrowser browser
|
|
)
|
|
auto
|
|
| allowauto = liftIO startNoRepo
|
|
| otherwise = do
|
|
d <- liftIO getCurrentDirectory
|
|
error $ "no git repository in " ++ d
|
|
checkpid = do
|
|
pidfile <- fromRepo gitAnnexPidFile
|
|
liftIO $ isJust <$> checkDaemon pidfile
|
|
checkshim f = liftIO $ doesFileExist f
|
|
|
|
{- When run without a repo, see if there is an autoStartFile,
|
|
- and if so, start the first available listed repository.
|
|
- If not, it's our first time being run! -}
|
|
startNoRepo :: IO ()
|
|
startNoRepo = do
|
|
autostartfile <- autoStartFile
|
|
ifM (doesFileExist autostartfile) ( autoStart autostartfile , firstRun )
|
|
|
|
autoStart :: FilePath -> IO ()
|
|
autoStart autostartfile = do
|
|
dirs <- nub . lines <$> readFile autostartfile
|
|
edirs <- filterM doesDirectoryExist dirs
|
|
case edirs of
|
|
[] -> firstRun -- what else can I do? Nothing works..
|
|
(d:_) -> do
|
|
changeWorkingDirectory d
|
|
state <- Annex.new =<< Git.CurrentRepo.get
|
|
void $ Annex.eval state $ doCommand $ start' False
|
|
|
|
{- Run the webapp without a repository, which prompts the user, makes one,
|
|
- changes to it, starts the regular assistant, and redirects the
|
|
- browser to its url.
|
|
-
|
|
- This is a very tricky dance -- The first webapp calls the signaler,
|
|
- which signals the main thread when it's ok to continue by writing to a
|
|
- MVar. The main thread starts the second webapp, and uses its callback
|
|
- to write its url back to the MVar, from where the signaler retrieves it,
|
|
- returning it to the first webapp, which does the redirect.
|
|
-
|
|
- Note that it's important that mainthread never terminates! Much
|
|
- of this complication is due to needing to keep the mainthread running.
|
|
-}
|
|
firstRun :: IO ()
|
|
firstRun = do
|
|
{- Without a repository, we cannot have an Annex monad, so cannot
|
|
- get a ThreadState. Using undefined is only safe because the
|
|
- webapp checks its noAnnex field before accessing the
|
|
- threadstate. -}
|
|
let st = undefined
|
|
{- Get a DaemonStatus without running in the Annex monad. -}
|
|
dstatus <- atomically . newTMVar =<< newDaemonStatus
|
|
d <- newAssistantData st dstatus
|
|
urlrenderer <- newUrlRenderer
|
|
v <- newEmptyMVar
|
|
let callback a = Just $ a v
|
|
void $ runAssistant d $ runNamedThread $
|
|
webAppThread d urlrenderer True
|
|
(callback signaler)
|
|
(callback mainthread)
|
|
where
|
|
signaler v = do
|
|
putMVar v ""
|
|
takeMVar v
|
|
mainthread v _url htmlshim = do
|
|
browser <- maybe Nothing webBrowser <$> Git.Config.global
|
|
openBrowser browser htmlshim
|
|
|
|
_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
|
|
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]
|
|
|
|
{- web.browser is a generic git config setting for a web browser program -}
|
|
webBrowser :: Git.Repo -> Maybe FilePath
|
|
webBrowser = Git.Config.getMaybe "web.browser"
|
|
|
|
fileUrl :: FilePath -> String
|
|
fileUrl file = "file://" ++ file
|