implemented firstrun repository creation and redirection to full webapp

Some of the trickiest code I've possibly ever written.

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