make other repositories list list all autostarted repos

And add a form to add another, unrelated repository
author: Joey Hess <joey@kitenet.net> 2012-09-18 17:50:07 -0400
committer: Joey Hess <joey@kitenet.net> 2012-09-18 17:50:07 -0400
commit: 18bae020ede6770dfbe00a3335c0e9f8b7f7fdf6 (patch)
tree: 74eb967c26258c40649e80d8992aee556b04f6f0
parent: 467844d7d3f703f99fcde1f951f33efda5e90074 (diff)
15 files changed, 166 insertions, 38 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 646734776..8a5ab4ec6 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -21,6 +21,7 @@ import Assistant.WebApp.Configurators.Local
 import Assistant.WebApp.Configurators.Ssh
 import Assistant.WebApp.Configurators.Pairing
 import Assistant.WebApp.Documentation
+import Assistant.WebApp.OtherRepos
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
@@ -72,24 +73,29 @@ webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer pos
 		, return app
 		)
 	runWebApp app' $ \port -> case mst of
-		Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
-		Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
+		Nothing -> withTempFile "webapp.html" $ \tmpfile _ ->
+			go port webapp tmpfile Nothing
+		Just st -> do
+			htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim
+			urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile
+			go port webapp htmlshim (Just urlfile)
 	where
 		thread = NamedThread thisThread
 		getreldir Nothing = return Nothing
 		getreldir (Just st) = Just <$>
 			(relHome =<< absPath
 				=<< runThreadState st (fromRepo repoPath))
-		go port webapp htmlshim = do
-			writeHtmlShim webapp port htmlshim
-			maybe noop (\a -> a (myUrl webapp port HomeR) htmlshim) onstartup
+		go port webapp htmlshim urlfile = do
+			debug thisThread ["running on port", show port]
+			let url = myUrl webapp port
+			maybe noop (`writeFile` url) urlfile
+			writeHtmlShim url htmlshim
+			maybe noop (\a -> a url 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. -}
-writeHtmlShim :: WebApp -> PortNumber -> FilePath -> IO ()
-writeHtmlShim webapp port file = do
-	debug thisThread ["running on port", show port]
-	viaTmp go file $ genHtmlShim webapp port
+writeHtmlShim :: String -> FilePath -> IO ()
+writeHtmlShim url file = viaTmp go file $ genHtmlShim url
 	where
 		go tmpfile content = do
 			h <- openFile tmpfile WriteMode
@@ -98,8 +104,8 @@ writeHtmlShim webapp port file = do
 			hClose h
 
 {- TODO: generate this static file using Yesod. -}
-genHtmlShim :: WebApp -> PortNumber -> String
-genHtmlShim webapp port = unlines
+genHtmlShim :: String -> String
+genHtmlShim url = unlines
 	[ "<html>"
 	, "<head>"
 	, "<title>Starting webapp...</title>"
@@ -111,10 +117,8 @@ genHtmlShim webapp port = unlines
 	, "</body>"
 	, "</html>"
 	]
-	where
-		url = myUrl webapp port HomeR
 
-myUrl :: WebApp -> PortNumber -> Route WebApp -> Url
-myUrl webapp port route = unpack $ yesodRender webapp urlbase route []
+myUrl :: WebApp -> PortNumber -> Url
+myUrl webapp port = unpack $ yesodRender webapp urlbase HomeR []
 	where
 		urlbase = pack $ "http://localhost:" ++ show port
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 1941c23ef..e2c3f167b 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -61,12 +61,12 @@ queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> Asso
 queueTransfers = queueTransfersMatching (const True)
 
 {- Adds transfers to queue for some of the known remotes, that match a
- - predicate. -}
+ - condition. -}
 queueTransfersMatching :: (UUID -> Bool) -> Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex ()
-queueTransfersMatching pred schedule q dstatus k f direction = do
+queueTransfersMatching matching schedule q dstatus k f direction = do
 	rs <- sufficientremotes
 		=<< knownRemotes <$> liftIO (getDaemonStatus dstatus)
-	let matchingrs = filter (pred . Remote.uuid) rs
+	let matchingrs = filter (matching . Remote.uuid) rs
 	if null matchingrs
 		then defer
 		else forM_ matchingrs $ \r -> liftIO $
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index 64dcd48e3..c8eaeecf0 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -15,6 +15,7 @@ import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Utility.NotificationBroadcaster
 import Utility.Yesod
+import Locations.UserConfig
 
 import Yesod
 import Text.Hamlet
@@ -65,8 +66,11 @@ bootstrap navbaritem content = do
 		navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
 
 newWebAppState :: IO (TMVar WebAppState)
-newWebAppState = liftIO $ atomically $
-	newTMVar $ WebAppState { showIntro = True }
+newWebAppState = do
+	otherrepos <- listOtherRepos
+	atomically $ newTMVar $ WebAppState
+		{ showIntro = True
+		, otherRepos = otherrepos }
 
 getWebAppState :: forall sub. GHandler sub WebApp WebAppState
 getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
@@ -139,3 +143,16 @@ redirectBack = do
 	clearUltDest
 	setUltDestReferer
 	redirectUltDest HomeR
+
+{- List of other known repsitories, and link to add a new one. -}
+otherReposWidget :: Widget
+otherReposWidget = do
+	repolist <- lift $ otherRepos <$> getWebAppState
+	$(widgetFile "otherrepos")
+
+listOtherRepos :: IO [(String, String)]
+listOtherRepos = do
+	f <- autoStartFile
+	dirs <- ifM (doesFileExist f) ( lines <$> readFile f, return [])
+	names <- mapM relHome dirs
+	return $ sort $ zip names dirs
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index e77986674..a86d13026 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/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
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index b4e46bd68..fc6b8ea1b 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/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
diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs
new file mode 100644
index 000000000..0c429d182
--- /dev/null
+++ b/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
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index c00150b65..4198cd428 100644
--- a/Assistant/WebApp/Types.hs
+++ b/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
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index bfc658372..d26e0c567 100644
--- a/Assistant/WebApp/routes
+++ b/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
diff --git a/Locations.hs b/Locations.hs
index 3e278dcbb..397081cc4 100644
--- a/Locations.hs
+++ b/Locations.hs
@@ -27,6 +27,7 @@ module Locations (
 	gitAnnexDaemonStatusFile,
 	gitAnnexLogFile,
 	gitAnnexHtmlShim,
+	gitAnnexUrlFile,
 	gitAnnexSshDir,
 	gitAnnexRemotesDir,
 	gitAnnexAssistantDefaultDir,
@@ -167,6 +168,10 @@ gitAnnexLogFile r = gitAnnexDir r </> "daemon.log"
 gitAnnexHtmlShim :: Git.Repo -> FilePath
 gitAnnexHtmlShim r = gitAnnexDir r </> "webapp.html"
 
+{- File containing the url to the webapp. -}
+gitAnnexUrlFile :: Git.Repo -> FilePath
+gitAnnexUrlFile r = gitAnnexDir r </> "url"
+
 {- .git/annex/ssh/ is used for ssh connection caching -}
 gitAnnexSshDir :: Git.Repo -> FilePath
 gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 21d2d2c97..8aac5f7d5 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -10,7 +10,6 @@ module Logs.Transfer where
 import Common.Annex
 import Annex.Perms
 import Annex.Exception
-import Annex.UUID
 import qualified Git
 import Types.Remote
 import Types.Key
diff --git a/templates/configurators/newrepository.hamlet b/templates/configurators/newrepository.hamlet
new file mode 100644
index 000000000..d2bdad9b9
--- /dev/null
+++ b/templates/configurators/newrepository.hamlet
@@ -0,0 +1,15 @@
+<div .span9 .hero-unit>
+  <h2>
+    Add another repository
+  <p>
+    The form below will make a separate repository, that is not synced #
+    with your existing repository. You can use the new repository for #
+    different sorts of files, that are synced and shared with other #
+    devices and users.
+  <p>
+    <form .form-inline enctype=#{enctype}>
+      ^{form}
+  <p>
+    <i .icon-asterisk></i> #
+    Do you want to add another repository that is kept in sync with #
+    the current one? If so, <a href="@{RepositoriesR}">go here</a>.
diff --git a/templates/configurators/firstrepository.hamlet b/templates/configurators/newrepository/first.hamlet
index ac28119eb..88b1fa72b 100644
--- a/templates/configurators/firstrepository.hamlet
+++ b/templates/configurators/newrepository/first.hamlet
@@ -10,5 +10,5 @@
     Files in this repository will managed by git-annex, #
     and kept in sync with your repositories on other devices.
   <p>
-  <form .form-inline enctype=#{enctype}>
-    ^{form}
+    <form .form-inline enctype=#{enctype}>
+      ^{form}
diff --git a/templates/configurators/firstrepository/form.hamlet b/templates/configurators/newrepository/form.hamlet
index 6c2405be6..6c2405be6 100644
--- a/templates/configurators/firstrepository/form.hamlet
+++ b/templates/configurators/newrepository/form.hamlet
diff --git a/templates/otherrepos.hamlet b/templates/otherrepos.hamlet
new file mode 100644
index 000000000..f1738f2f0
--- /dev/null
+++ b/templates/otherrepos.hamlet
@@ -0,0 +1,10 @@
+<ul .dropdown-menu>
+  $forall (name, path) <- repolist
+    <li>
+      <a href="@{SwitchToRepositoryR path}">
+        #{name}
+  $if not (null repolist)
+    <li .divider></li>
+  <li>
+    <a href="@{NewRepositoryR}">
+      Add another repository
diff --git a/templates/page.hamlet b/templates/page.hamlet
index 0c07c9130..7648b6107 100644
--- a/templates/page.hamlet
+++ b/templates/page.hamlet
@@ -6,7 +6,8 @@
       <ul .nav>
         $forall (name, route, isactive) <- navbar
           <li :isactive:.active>
-            <a href="@{route}">#{name}</a>
+            <a href="@{route}">
+              #{name}
       $maybe reldir <- relDir webapp
         <ul .nav .pull-right>
           <li>
@@ -15,8 +16,7 @@
             <a .dropdown-toggle data-toggle="dropdown" href="#menu1">
               Current Repository: #{reldir}
               <b .caret></b>
-            <ul .dropdown-menu>
-               <li><a href="@{RepositoriesR}">Add another repository</a></li>
+            ^{otherReposWidget}
       $nothing
 <div .container-fluid>
   <div .row-fluid>
author	Joey Hess <joey@kitenet.net>	2012-09-18 17:50:07 -0400
committer	Joey Hess <joey@kitenet.net>	2012-09-18 17:50:07 -0400
commit	18bae020ede6770dfbe00a3335c0e9f8b7f7fdf6 (patch)
tree	74eb967c26258c40649e80d8992aee556b04f6f0
parent	467844d7d3f703f99fcde1f951f33efda5e90074 (diff)