make other repositories list list all autostarted repos

And add a form to add another, unrelated repository

Assistant/WebApp/Configurators/Local.hs

@@ -104,30 +104,47 @@ defaultRepositoryPath firstrun = do
 				)
 		else return cwd
 
-firstRepositoryForm :: Form RepositoryPath
-firstRepositoryForm msg = do
-	path <- T.pack . addTrailingPathSeparator
-		<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun)
-	(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
+newRepositoryForm :: FilePath -> Form RepositoryPath
+newRepositoryForm defpath msg = do
+	(pathRes, pathView) <- mreq (repositoryPathField True) ""
+		(Just $ T.pack $ addTrailingPathSeparator defpath)
 	let (err, errmsg) = case pathRes of
 		FormMissing -> (False, "")
 		FormFailure l -> (True, concat $ map T.unpack l)
 		FormSuccess _ -> (False, "")
 	let form = do
 		webAppFormAuthToken
-		$(widgetFile "configurators/firstrepository/form")
+		$(widgetFile "configurators/newrepository/form")
 	return (RepositoryPath <$> pathRes, form)
 
 {- Making the first repository, when starting the webapp for the first time. -}
 getFirstRepositoryR :: Handler RepHtml
 getFirstRepositoryR = bootstrap (Just Config) $ do
 	sideBarDisplay
-	setTitle "Getting started"
-	((res, form), enctype) <- lift $ runFormGet firstRepositoryForm
+	setTitle "Getting started"	
+	path <- liftIO . defaultRepositoryPath =<< lift inFirstRun
+	((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path
 	case res of
 		FormSuccess (RepositoryPath p) -> lift $
 			startFullAssistant $ T.unpack p
-		_ -> $(widgetFile "configurators/firstrepository")
+		_ -> $(widgetFile "configurators/newrepository/first")
+
+{- Adding a new, separate repository. -}
+getNewRepositoryR :: Handler RepHtml
+getNewRepositoryR = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Add another repository"
+	home <- liftIO myHomeDir
+	((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home
+	case res of
+		FormSuccess (RepositoryPath p) -> lift $ do
+			let path = T.unpack p
+			liftIO $ do
+				makeRepo path False
+				initRepo path Nothing
+				addAutoStart path
+			redirect $ SwitchToRepositoryR path
+		_ -> $(widgetFile "configurators/newrepository")
 
 data RemovableDrive = RemovableDrive 
 	{ diskFree :: Maybe Integer

Assistant/WebApp/DashBoard.hs

@@ -94,6 +94,10 @@ getHomeR = ifM (inFirstRun)
 	, bootstrap (Just DashBoard) $ dashboard True
 	)
 
+{- Used to test if the webapp is running. -}
+headHomeR :: Handler ()
+headHomeR = noop
+
 {- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
 getNoScriptR :: Handler RepHtml
 getNoScriptR = bootstrap (Just DashBoard) $ dashboard False

Assistant/WebApp/OtherRepos.hs

@@ -0,0 +1,53 @@
+{- git-annex assistant webapp switching to other repos
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.OtherRepos where
+
+import Assistant.Common
+import Assistant.WebApp.Types
+import qualified Git.Construct
+import qualified Git.Config
+import Locations.UserConfig
+import qualified Utility.Url as Url
+
+import Yesod
+import Control.Concurrent
+import System.Process (cwd)
+
+{- Starts up the assistant in the repository, and waits for it to create
+ - a gitAnnexUrlFile. Waits for the assistant to be up and listening for
+ - connections by testing the url. Once it's running, redirect to it.
+ -}
+getSwitchToRepositoryR :: FilePath -> Handler RepHtml
+getSwitchToRepositoryR repo = do
+	liftIO startassistant
+	url <- liftIO geturl
+	redirect url
+	where
+		startassistant = do
+			program <- readProgramFile
+			void $ forkIO $ void $ createProcess $
+				(proc program ["assistant"])
+					{ cwd = Just repo }
+		geturl = do
+			r <- Git.Config.read =<< Git.Construct.fromPath repo
+			waiturl $ gitAnnexUrlFile r
+		waiturl urlfile = do
+			v <- tryIO $ readFile urlfile
+			case v of
+				Left _ -> delayed $ waiturl urlfile
+				Right url -> ifM (listening url)
+					( return url
+					, delayed $ waiturl urlfile
+					)
+		listening url = catchBoolIO $ 
+			fst <$> Url.exists url []
+		delayed a = do
+			threadDelay 100000 -- 1/10th of a second
+			a

Assistant/WebApp/Types.hs

@@ -65,7 +65,8 @@ instance RenderMessage WebApp FormMessage where
 type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
 
 data WebAppState = WebAppState
-	{ showIntro :: Bool
+	{ showIntro :: Bool -- should the into message be displayed?
+	, otherRepos :: [(String, String)] -- name and path to other repos
 	}
 
 instance PathPiece SshData where

Assistant/WebApp/routes

@@ -1,11 +1,14 @@
-/ HomeR GET
+/ HomeR GET HEAD
 /noscript NoScriptR GET
 /noscript/auto NoScriptAutoR GET
 /about AboutR GET
 
 /config ConfigR GET
 /config/repository RepositoriesR GET
-/config/repository/first FirstRepositoryR GET
+
+/config/repository/new/first FirstRepositoryR GET
+/config/repository/new NewRepositoryR GET
+/config/repository/switchto/#FilePath SwitchToRepositoryR GET
 
 /config/repository/add/drive AddDriveR GET
 /config/repository/add/ssh AddSshR GET