implemented firstrun repository creation and redirection to full webapp

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

3 files changed, 55 insertions, 9 deletions

diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index ad2bff892..a5484b5be 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/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)
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index c2a021246..1b767c642 100644
--- a/Assistant/WebApp.hs
+++ b/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
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
index b9630b10a..5c2a1f25e 100644
--- a/Assistant/WebApp/Configurators.hs
+++ b/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