split repolist out of configuration, into its own tab (temporarily)

Assistant/Threads/WebApp.hs

@@ -16,6 +16,7 @@ import Assistant.WebApp.Types
 import Assistant.WebApp.DashBoard
 import Assistant.WebApp.SideBar
 import Assistant.WebApp.Notifications
+import Assistant.WebApp.RepoList
 import Assistant.WebApp.Configurators
 import Assistant.WebApp.Configurators.Edit
 import Assistant.WebApp.Configurators.Local

Assistant/WebApp/Configurators.hs

@@ -10,23 +10,11 @@
 module Assistant.WebApp.Configurators where
 
 import Assistant.WebApp.Common
-import Assistant.DaemonStatus
-import Assistant.WebApp.Notifications
-import Assistant.WebApp.Utility
 import Assistant.WebApp.Configurators.Local
-import qualified Annex
-import qualified Remote
-import qualified Types.Remote as Remote
-import Annex.UUID (getUUID)
-import Logs.Remote
-import Logs.Trust
-import qualified Git
 #ifdef WITH_XMPP
 import Assistant.XMPP.Client
 #endif
 
-import qualified Data.Map as M
-
 {- The main configuration screen. -}
 getConfigurationR :: Handler RepHtml
 getConfigurationR = ifM (inFirstRun)
@@ -39,164 +27,3 @@ getConfigurationR = ifM (inFirstRun)
 #endif
 		$(widgetFile "configurators/main")
 	)
-
-{- An intro message, list of repositories, and nudge to make more. -}
-introDisplay :: Text -> Widget
-introDisplay ident = do
-	webapp <- lift getYesod
-	repolist <- lift $ repoList $ RepoSelector
-		{ onlyCloud = False
-		, onlyConfigured = True
-		, includeHere = False
-		}
-	let n = length repolist
-	let numrepos = show n
-	$(widgetFile "configurators/intro")
-	lift $ modifyWebAppState $ \s -> s { showIntro = False }
-
-makeMiscRepositories :: Widget
-makeMiscRepositories = $(widgetFile "configurators/repositories/misc")
-
-makeCloudRepositories :: Bool -> Widget
-makeCloudRepositories onlyTransfer = $(widgetFile "configurators/repositories/cloud")
-
-{- Lists known repositories, followed by options to add more. -}
-getRepositoriesR :: Handler RepHtml
-getRepositoriesR = page "Repositories" (Just Configuration) $ do
-	let repolist = repoListDisplay $ RepoSelector
-		{ onlyCloud = False
-		, onlyConfigured = False
-		, includeHere = True
-		}
-	$(widgetFile "configurators/repositories")
-
-data Actions
-	= DisabledRepoActions
-		{ setupRepoLink :: Route WebApp }
-	| SyncingRepoActions
-		{ setupRepoLink :: Route WebApp
-		, syncToggleLink :: Route WebApp
-		}
-	| NotSyncingRepoActions
-		{ setupRepoLink :: Route WebApp
-		, syncToggleLink :: Route WebApp
-		}
-
-mkSyncingRepoActions :: UUID -> Actions
-mkSyncingRepoActions u = SyncingRepoActions
-	{ setupRepoLink = EditRepositoryR u
-	, syncToggleLink = DisableSyncR u
-	}
-
-mkNotSyncingRepoActions :: UUID -> Actions
-mkNotSyncingRepoActions u = NotSyncingRepoActions
-	{ setupRepoLink = EditRepositoryR u
-	, syncToggleLink = EnableSyncR u
-	}
-
-needsEnabled :: Actions -> Bool
-needsEnabled (DisabledRepoActions _) = True
-needsEnabled _ = False
-
-notSyncing :: Actions -> Bool
-notSyncing (SyncingRepoActions _ _) = False
-notSyncing _ = True
-
-{- Called by client to get a list of repos, that refreshes
- - when new repos as added.
- -
- - Returns a div, which will be inserted into the calling page.
- -}
-getRepoListR :: RepoListNotificationId -> Handler RepHtml
-getRepoListR (RepoListNotificationId nid reposelector) = do
-	waitNotifier getRepoListBroadcaster nid
-	p <- widgetToPageContent $ repoListDisplay reposelector
-	hamletToRepHtml $ [hamlet|^{pageBody p}|]
-
-repoListDisplay :: RepoSelector -> Widget
-repoListDisplay reposelector = do
-	autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int)
-
-	repolist <- lift $ repoList reposelector
-
-	$(widgetFile "configurators/repositories/list")
-
-  where
-	ident = "repolist"
-
-type RepoList = [(String, String, Actions)]
-
-{- A numbered list of known repositories,
- - with actions that can be taken on them. -}
-repoList :: RepoSelector -> Handler RepoList
-repoList reposelector
-	| onlyConfigured reposelector = list =<< configured
-	| otherwise = list =<< (++) <$> configured <*> rest
-  where
-	configured = do
-		rs <- filter wantedrepo . syncRemotes
-			<$> liftAssistant getDaemonStatus
-		liftAnnex $ do
-			let us = map Remote.uuid rs
-			let l = zip us $ map mkSyncingRepoActions us
-			if includeHere reposelector
-				then do
-					u <- getUUID
-					autocommit <- annexAutoCommit <$> Annex.getGitConfig
-					let hereactions = if autocommit
-						then mkSyncingRepoActions u
-						else mkNotSyncingRepoActions u
-					let here = (u, hereactions)
-					return $ here : l
-				else return l
-	rest = liftAnnex $ do
-		m <- readRemoteLog
-		unconfigured <- map snd . catMaybes . filter wantedremote 
-			. map (findinfo m)
-			<$> (trustExclude DeadTrusted $ M.keys m)
-		unsyncable <- map Remote.uuid . filter wantedrepo .
-			filter (not . remoteAnnexSync . Remote.gitconfig)
-			<$> Remote.enabledRemoteList
-		return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
-	wantedrepo r
-		| Remote.readonly r = False
-		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r)
-		| otherwise = True
-	wantedremote Nothing = False
-	wantedremote (Just (iscloud, _))
-		| onlyCloud reposelector = iscloud
-		| otherwise = True
-	findinfo m u = case M.lookup u m of
-		Nothing -> Nothing
-		Just c -> case M.lookup "type" c of
-			Just "rsync" -> val True EnableRsyncR
-			Just "directory" -> val False EnableDirectoryR
-#ifdef WITH_S3
-			Just "S3" -> val True EnableS3R
-#endif
-			Just "glacier" -> val True EnableGlacierR
-#ifdef WITH_WEBDAV
-			Just "webdav" -> val True EnableWebDAVR
-#endif
-			_ -> Nothing
-	  where
-		val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
-	list l = liftAnnex $ do
-		let l' = nubBy (\x y -> fst x == fst y) l
-		zip3
-			<$> pure counter
-			<*> Remote.prettyListUUIDs (map fst l')
-			<*> pure (map snd l')
-	counter = map show ([1..] :: [Int])
-
-getEnableSyncR :: UUID -> Handler ()
-getEnableSyncR = flipSync True
-
-getDisableSyncR :: UUID -> Handler ()
-getDisableSyncR = flipSync False
-
-flipSync :: Bool -> UUID -> Handler ()
-flipSync enable uuid = do
-	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
-	changeSyncable mremote enable
-	redirect RepositoriesR

Assistant/WebApp/Configurators/Pairing.hs

@@ -31,7 +31,7 @@ import Assistant.XMPP.Git
 import Network.Protocol.XMPP
 import Assistant.Types.NetMessager
 import Assistant.NetMessager
-import Assistant.WebApp.Configurators
+import Assistant.WebApp.RepoList
 import Assistant.WebApp.Configurators.XMPP
 #endif
 import Utility.UserInfo

Assistant/WebApp/DashBoard.hs

@@ -12,7 +12,7 @@ module Assistant.WebApp.DashBoard where
 import Assistant.WebApp.Common
 import Assistant.WebApp.Utility
 import Assistant.WebApp.Notifications
-import Assistant.WebApp.Configurators
+import Assistant.WebApp.RepoList
 import Assistant.TransferQueue
 import Utility.NotificationBroadcaster
 import Logs.Transfer

Assistant/WebApp/Page.hs

@@ -19,21 +19,23 @@ import Yesod
 import Text.Hamlet
 import Data.Text (Text)
 
-data NavBarItem = DashBoard | Configuration | About
+data NavBarItem = DashBoard | Repositories | Configuration | About
-	deriving (Eq)
+	deriving (Eq, Ord, Enum, Bounded)
 
 navBarName :: NavBarItem -> Text
 navBarName DashBoard = "Dashboard"
+navBarName Repositories = "Repositories"
 navBarName Configuration = "Configuration"
 navBarName About = "About"
 
 navBarRoute :: NavBarItem -> Route WebApp
 navBarRoute DashBoard = HomeR
+navBarRoute Repositories = RepositoriesR
 navBarRoute Configuration = ConfigurationR
 navBarRoute About = AboutR
 
 defaultNavBar :: [NavBarItem]
-defaultNavBar = [DashBoard, Configuration, About]
+defaultNavBar = [minBound .. maxBound]
 
 firstRunNavBar :: [NavBarItem]
 firstRunNavBar = [Configuration, About]

Assistant/WebApp/RepoList.hs

@@ -0,0 +1,187 @@
+{- git-annex assistant webapp repository list
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-}
+
+module Assistant.WebApp.RepoList where
+
+import Assistant.WebApp.Common
+import Assistant.DaemonStatus
+import Assistant.WebApp.Notifications
+import Assistant.WebApp.Utility
+import qualified Annex
+import qualified Remote
+import qualified Types.Remote as Remote
+import Annex.UUID (getUUID)
+import Logs.Remote
+import Logs.Trust
+import qualified Git
+#ifdef WITH_XMPP
+#endif
+
+import qualified Data.Map as M
+
+{- An intro message, list of repositories, and nudge to make more. -}
+introDisplay :: Text -> Widget
+introDisplay ident = do
+	webapp <- lift getYesod
+	repolist <- lift $ repoList $ RepoSelector
+		{ onlyCloud = False
+		, onlyConfigured = True
+		, includeHere = False
+		}
+	let n = length repolist
+	let numrepos = show n
+	$(widgetFile "configurators/intro")
+	lift $ modifyWebAppState $ \s -> s { showIntro = False }
+
+makeMiscRepositories :: Widget
+makeMiscRepositories = $(widgetFile "configurators/repositories/misc")
+
+makeCloudRepositories :: Bool -> Widget
+makeCloudRepositories onlyTransfer = $(widgetFile "configurators/repositories/cloud")
+
+{- Lists known repositories, followed by options to add more. -}
+getRepositoriesR :: Handler RepHtml
+getRepositoriesR = page "Repositories" (Just Repositories) $ do
+	let repolist = repoListDisplay $ RepoSelector
+		{ onlyCloud = False
+		, onlyConfigured = False
+		, includeHere = True
+		}
+	$(widgetFile "configurators/repositories")
+
+data Actions
+	= DisabledRepoActions
+		{ setupRepoLink :: Route WebApp }
+	| SyncingRepoActions
+		{ setupRepoLink :: Route WebApp
+		, syncToggleLink :: Route WebApp
+		}
+	| NotSyncingRepoActions
+		{ setupRepoLink :: Route WebApp
+		, syncToggleLink :: Route WebApp
+		}
+
+mkSyncingRepoActions :: UUID -> Actions
+mkSyncingRepoActions u = SyncingRepoActions
+	{ setupRepoLink = EditRepositoryR u
+	, syncToggleLink = DisableSyncR u
+	}
+
+mkNotSyncingRepoActions :: UUID -> Actions
+mkNotSyncingRepoActions u = NotSyncingRepoActions
+	{ setupRepoLink = EditRepositoryR u
+	, syncToggleLink = EnableSyncR u
+	}
+
+needsEnabled :: Actions -> Bool
+needsEnabled (DisabledRepoActions _) = True
+needsEnabled _ = False
+
+notSyncing :: Actions -> Bool
+notSyncing (SyncingRepoActions _ _) = False
+notSyncing _ = True
+
+{- Called by client to get a list of repos, that refreshes
+ - when new repos as added.
+ -
+ - Returns a div, which will be inserted into the calling page.
+ -}
+getRepoListR :: RepoListNotificationId -> Handler RepHtml
+getRepoListR (RepoListNotificationId nid reposelector) = do
+	waitNotifier getRepoListBroadcaster nid
+	p <- widgetToPageContent $ repoListDisplay reposelector
+	hamletToRepHtml $ [hamlet|^{pageBody p}|]
+
+repoListDisplay :: RepoSelector -> Widget
+repoListDisplay reposelector = do
+	autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int)
+
+	repolist <- lift $ repoList reposelector
+
+	$(widgetFile "configurators/repositories/list")
+
+  where
+	ident = "repolist"
+
+type RepoList = [(String, String, Actions)]
+
+{- A numbered list of known repositories,
+ - with actions that can be taken on them. -}
+repoList :: RepoSelector -> Handler RepoList
+repoList reposelector
+	| onlyConfigured reposelector = list =<< configured
+	| otherwise = list =<< (++) <$> configured <*> rest
+  where
+	configured = do
+		rs <- filter wantedrepo . syncRemotes
+			<$> liftAssistant getDaemonStatus
+		liftAnnex $ do
+			let us = map Remote.uuid rs
+			let l = zip us $ map mkSyncingRepoActions us
+			if includeHere reposelector
+				then do
+					u <- getUUID
+					autocommit <- annexAutoCommit <$> Annex.getGitConfig
+					let hereactions = if autocommit
+						then mkSyncingRepoActions u
+						else mkNotSyncingRepoActions u
+					let here = (u, hereactions)
+					return $ here : l
+				else return l
+	rest = liftAnnex $ do
+		m <- readRemoteLog
+		unconfigured <- map snd . catMaybes . filter wantedremote 
+			. map (findinfo m)
+			<$> (trustExclude DeadTrusted $ M.keys m)
+		unsyncable <- map Remote.uuid . filter wantedrepo .
+			filter (not . remoteAnnexSync . Remote.gitconfig)
+			<$> Remote.enabledRemoteList
+		return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
+	wantedrepo r
+		| Remote.readonly r = False
+		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r)
+		| otherwise = True
+	wantedremote Nothing = False
+	wantedremote (Just (iscloud, _))
+		| onlyCloud reposelector = iscloud
+		| otherwise = True
+	findinfo m u = case M.lookup u m of
+		Nothing -> Nothing
+		Just c -> case M.lookup "type" c of
+			Just "rsync" -> val True EnableRsyncR
+			Just "directory" -> val False EnableDirectoryR
+#ifdef WITH_S3
+			Just "S3" -> val True EnableS3R
+#endif
+			Just "glacier" -> val True EnableGlacierR
+#ifdef WITH_WEBDAV
+			Just "webdav" -> val True EnableWebDAVR
+#endif
+			_ -> Nothing
+	  where
+		val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
+	list l = liftAnnex $ do
+		let l' = nubBy (\x y -> fst x == fst y) l
+		zip3
+			<$> pure counter
+			<*> Remote.prettyListUUIDs (map fst l')
+			<*> pure (map snd l')
+	counter = map show ([1..] :: [Int])
+
+getEnableSyncR :: UUID -> Handler ()
+getEnableSyncR = flipSync True
+
+getDisableSyncR :: UUID -> Handler ()
+getDisableSyncR = flipSync False
+
+flipSync :: Bool -> UUID -> Handler ()
+flipSync enable uuid = do
+	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
+	changeSyncable mremote enable
+	redirect RepositoriesR

Assistant/WebApp/routes

@@ -1,6 +1,9 @@
 / HomeR GET HEAD
+/repositories RepositoriesR GET
+
 /noscript NoScriptR GET
 /noscript/auto NoScriptAutoR GET
+
 /about AboutR GET
 /about/license LicenseR GET
 /about/repogroups RepoGroupR GET
@@ -12,7 +15,6 @@
 /log LogR GET
 
 /config ConfigurationR GET
-/config/repository RepositoriesR GET
 /config/preferences PreferencesR GET
 /config/xmpp XMPPR GET
 

templates/configurators/main.hamlet

@@ -2,11 +2,11 @@
   <div .row-fluid>
     <div .span4>
       <h3>
-        <a href="@{RepositoriesR}">
+        <a href="@{PreferencesR}">
-          Manage repositories
+          Preferences
       <p>
-        Distribute the files in this repository to other devices, #
+        Tune the behavior of git-annex, including how many copies #
-        make backups, and more, by adding repositories.
+        to retain of each file, and how much disk space it can use.
     <div .span4>
       $if xmppconfigured
         <h3>
@@ -22,10 +22,3 @@
        <p>
          Keep in touch with remote devices, and with your friends, #
          by configuring a jabber account.
-    <div .span4>
-      <h3>
-        <a href="@{PreferencesR}">
-          Preferences
-      <p>
-        Tune the behavior of git-annex, including how many copies #
-        to retain of each file, and how much disk space it can use.