implemented firstrun repository creation and redirection to full webapp

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

Assistant.hs

@@ -122,7 +122,10 @@ import Utility.ThreadScheduler
 
 import Control.Concurrent
 
-startDaemon :: Bool -> Bool -> Maybe (FilePath -> IO ()) -> Annex ()
+stopDaemon :: Annex ()
+stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
+
+startDaemon :: Bool -> Bool -> Maybe (Url -> FilePath -> IO ()) -> Annex ()
 startDaemon assistant foreground webappwaiter
 	| foreground = do
 		showStart (if assistant then "assistant" else "watch") "."
@@ -132,10 +135,15 @@ startDaemon assistant foreground webappwaiter
 		pidfile <- fromRepo gitAnnexPidFile
 		go $ Utility.Daemon.daemonize logfd (Just pidfile) False
 	where
-		go daemonize = withThreadState $ \st -> do
-			checkCanWatch
-			dstatus <- startDaemonStatus
-			liftIO $ daemonize $ run dstatus st
+		go d = startAssistant assistant d webappwaiter
+
+startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (Url -> FilePath -> IO ()) -> Annex ()
+startAssistant assistant daemonize webappwaiter = do
+	withThreadState $ \st -> do
+		checkCanWatch
+		dstatus <- startDaemonStatus
+		liftIO $ daemonize $ run dstatus st
+	where
 		run dstatus st = do
 			changechan <- newChangeChan
 			commitchan <- newCommitChan
@@ -155,12 +163,8 @@ startDaemon assistant foreground webappwaiter
 				, mountWatcherThread st dstatus scanremotes
 				, transferScannerThread st dstatus scanremotes transferqueue
 #ifdef WITH_WEBAPP
-				, webAppThread (Just st) dstatus transferqueue webappwaiter
+				, webAppThread (Just st) dstatus transferqueue Nothing webappwaiter
 #endif
 				, watchThread st dstatus transferqueue changechan
 				]
-			debug "Assistant" ["all threads started"]
 			waitForTermination
-
-stopDaemon :: Annex ()
-stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile

Assistant/Threads/WebApp.hs

@@ -38,8 +38,16 @@ thisThread = "WebApp"
 
 mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
 
-webAppThread :: (Maybe ThreadState) -> DaemonStatusHandle -> TransferQueue -> Maybe (FilePath -> IO ()) -> IO ()
-webAppThread mst dstatus transferqueue onstartup = do
+type Url = String
+
+webAppThread 
+	:: (Maybe ThreadState) 
+	-> DaemonStatusHandle
+	-> TransferQueue
+	-> Maybe (IO String)
+	-> Maybe (Url -> FilePath -> IO ())
+	-> IO ()
+webAppThread mst dstatus transferqueue postfirstrun onstartup = do
 	webapp <- WebApp
 		<$> pure mst
 		<*> pure dstatus
@@ -48,6 +56,7 @@ webAppThread mst dstatus transferqueue onstartup = do
 		<*> getreldir mst
 		<*> pure $(embed "static")
 		<*> newWebAppState
+		<*> pure postfirstrun
 	app <- toWaiAppPlain webapp
 	app' <- ifM debugEnabled
 		( return $ httpDebugLogger app
@@ -66,7 +75,7 @@ webAppThread mst dstatus transferqueue onstartup = do
 				else dir
 		go port webapp htmlshim = do
 			writeHtmlShim webapp port htmlshim
-			maybe noop (\a -> a htmlshim) onstartup
+			maybe noop (\a -> a (myUrl webapp port) htmlshim) onstartup
 
 {- Creates a html shim file that's used to redirect into the webapp,
  - to avoid exposing the secretToken when launching the web browser. -}
@@ -85,5 +94,8 @@ writeHtmlShim webapp port file = do
 genHtmlShim :: WebApp -> PortNumber -> String
 genHtmlShim webapp port = renderHtml $(shamletFile $ hamletTemplate "htmlshim")
 	where
-		url = "http://localhost:" ++ show port ++
-			"/?auth=" ++ unpack (secretToken webapp)
+		url = myUrl webapp port
+
+myUrl :: WebApp -> PortNumber -> Url
+myUrl webapp port = "http://localhost:" ++ show port ++
+	"/?auth=" ++ unpack (secretToken webapp)

Assistant/WebApp.hs

@@ -37,6 +37,7 @@ data WebApp = WebApp
 	, relDir :: Maybe FilePath
 	, getStatic :: Static
 	, webAppState :: TMVar WebAppState
+	, postFirstRun :: Maybe (IO String)
 	}
 
 data NavBarItem = DashBoard | Config | About

Assistant/WebApp/Configurators.hs

@@ -17,11 +17,16 @@ import qualified Remote
 import Logs.Web (webUUID)
 import Logs.Trust
 import Annex.UUID (getUUID)
+import Init
+import qualified Git.Construct
+import qualified Git.Config
+import qualified Annex
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Char
+import System.Posix.Directory
 
 {- An intro message, list of repositories, and nudge to make more. -}
 introDisplay :: Text -> Widget
@@ -104,7 +109,7 @@ defaultRepositoryPath :: Bool -> IO FilePath
 defaultRepositoryPath firstrun = do
 	cwd <- liftIO $ getCurrentDirectory
 	home <- myHomeDir
-	if home == cwd && firstRun
+	if home == cwd && firstrun
 		then ifM (doesDirectoryExist $ home </> "Desktop")
 			(return "~/Desktop/annex", return "~/annex")
 		else return cwd
@@ -112,8 +117,8 @@ defaultRepositoryPath firstrun = do
 addRepositoryForm :: Form RepositoryPath
 addRepositoryForm msg = do
 	path <- T.pack . addTrailingPathSeparator
-		<$> liftIO defaultRepositoryPath =<< lift inFirstRun
-	(pathRes, pathView) <- mreq (repositoryPathField True) ""(Just path)
+		<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun)
+	(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
 	let (err, errmsg) = case pathRes of
 		FormMissing -> (False, "")
 		FormFailure l -> (True, concat $ map T.unpack l)
@@ -128,8 +133,36 @@ addRepository firstrun = do
 	setTitle $ if firstrun then "Getting started" else "Add repository"
 	((res, form), enctype) <- lift $ runFormGet addRepositoryForm
 	case res of
-		FormSuccess (RepositoryPath p) -> error $ "TODO" ++ show p
+		FormSuccess (RepositoryPath p) -> go $ T.unpack p
 		_ -> $(widgetFile "configurators/addrepository")
+	where
+		go path
+			| firstrun = lift $ startFullAssistant path
+			| otherwise = error "TODO"
+
+{- Bootstraps from first run mode to a fully running assistant in a
+ - repository, by running the postFirstRun callback, which returns the
+ - url to the new webapp. -}
+startFullAssistant :: FilePath -> Handler ()
+startFullAssistant path = do
+	webapp <- getYesod
+	url <- liftIO $ do
+		makeRepo path
+		changeWorkingDirectory path
+		putStrLn "pre run"
+		r <- fromJust $ postFirstRun webapp
+		putStrLn $ "got " ++ r
+		return r
+	redirect $ T.pack url
+
+{- Makes a new git-annex repository. -}
+makeRepo :: FilePath -> IO ()
+makeRepo path = do
+	unlessM (boolSystem "git" [Param "init", Param "--quiet", File path]) $
+		error "git init failed!"
+	g <- Git.Config.read =<< Git.Construct.fromPath path
+	state <- Annex.new g
+	Annex.eval state $ initialize $ Just "new repo"
 
 getAddRepositoryR :: Handler RepHtml
 getAddRepositoryR = bootstrap (Just Config) $ do

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