implemented firstrun repository creation and redirection to full webapp

Some of the trickiest code I've possibly ever written.
This commit is contained in:
Joey Hess 2012-08-01 16:10:26 -04:00
parent 1efe4f3332
commit ecc168aba3
5 changed files with 110 additions and 25 deletions

View file

@ -14,11 +14,13 @@ import Assistant.DaemonStatus
import Assistant.TransferQueue
import Assistant.Threads.WebApp
import Utility.WebApp
import Utility.ThreadScheduler
import Utility.Daemon (checkDaemon)
import Init
import qualified Command.Watch
import qualified Git.CurrentRepo
import qualified Annex
import Control.Concurrent
import Control.Concurrent.STM
def :: [Command]
@ -42,7 +44,8 @@ start foreground stopdaemon = notBareRepo $ do
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
ifM (checkpid <&&> checkshim f) $
( liftIO $ openBrowser f
, startDaemon True foreground $ Just openBrowser
, startDaemon True foreground $ Just $
const openBrowser
)
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
@ -53,12 +56,44 @@ openBrowser :: FilePath -> IO ()
openBrowser htmlshim = unlessM (runBrowser url) $
error $ "failed to start web browser on url " ++ url
where
url = "file://" ++ htmlshim
url = fileUrl htmlshim
fileUrl :: FilePath -> String
fileUrl file = "file://" ++ file
{- 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
dstatus <- atomically . newTMVar =<< newDaemonStatus
transferqueue <- newTransferQueue
webAppThread Nothing dstatus transferqueue $ Just $ \f -> do
openBrowser f
waitForTermination
v <- newEmptyMVar
let callback a = Just $ a v
webAppThread Nothing dstatus transferqueue (callback signaler) (callback mainthread)
where
signaler v = do
putMVar v ""
putStrLn "signaler waiting..."
r <- takeMVar v
putStrLn "signaler got value"
return r
mainthread v _url htmlshim = do
openBrowser htmlshim
_wait <- takeMVar v
state <- Annex.new =<< Git.CurrentRepo.get
Annex.eval state $
startAssistant True id $ Just $ sendurlback v
sendurlback v url _htmlshim = putMVar v url