diff options
author | 2012-08-01 16:10:26 -0400 | |
---|---|---|
committer | 2012-08-01 16:10:26 -0400 | |
commit | ecc168aba30a0477381bcd2037c8d301368f3449 (patch) | |
tree | 13efe09744264cea284f87a0179a6b6023f987d6 /Command/WebApp.hs | |
parent | 1efe4f3332680be5ad9d5d496939d6757fbd2b0a (diff) |
implemented firstrun repository creation and redirection to full webapp
Some of the trickiest code I've possibly ever written.
Diffstat (limited to 'Command/WebApp.hs')
-rw-r--r-- | Command/WebApp.hs | 47 |
1 files changed, 41 insertions, 6 deletions
diff --git a/Command/WebApp.hs b/Command/WebApp.hs index e2442c37e..0ddf65c58 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -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 |