From 4e2e08b45afbc55a0bec94c931a12af8968994de Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 10 Oct 2012 16:23:41 -0400
Subject: [PATCH] ui for selecting a repository group

---
 Assistant/WebApp/Configurators/Edit.hs | 24 +++++++++++++++++++-----
 Logs/Group.hs                          | 10 ++++------
 Logs/PreferredContent.hs               |  5 ++---
 Types/StandardGroups.hs                |  6 +++---
 4 files changed, 28 insertions(+), 17 deletions(-)

diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs
index 2a688b329f..f279bf4b23 100644
--- a/Assistant/WebApp/Configurators/Edit.hs
+++ b/Assistant/WebApp/Configurators/Edit.hs
@@ -23,26 +23,40 @@ import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Map as M
+import qualified Data.Set as S
+
+data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup
+	deriving (Show, Eq)
 
 data RepoConfig = RepoConfig
 	{ repoDescription :: Text
-	, repoGroup :: Maybe StandardGroup
+	, repoGroup :: RepoGroup
 	}
 	deriving (Show)
 
 editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
 editRepositoryAForm def = RepoConfig
 	<$> areq textField "Description" (Just $ repoDescription def)
-	<*> aopt (selectFieldList standardgroups) "Repository group" (Just $ repoGroup def)
+	<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
 	where
-		standardgroups :: [(Text, StandardGroup)]
-		standardgroups = map (\g -> (T.pack $ descStandardGroup g , g))
+		standardgroups :: [(Text, RepoGroup)]
+		standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
 			[minBound :: StandardGroup .. maxBound :: StandardGroup]
+		customgroups :: [(Text, RepoGroup)]
+		customgroups = case repoGroup def of
+			RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)]
+			_ -> []
 
 getRepoConfig :: UUID -> Annex RepoConfig
 getRepoConfig uuid = RepoConfig
 	<$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap)
-	<*> (getStandardGroup uuid <$> groupMap)
+	<*> getrepogroup
+	where
+		getrepogroup = do
+			groups <- lookupGroups uuid
+			return $ 
+				maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
+					(getStandardGroup groups)
 
 getEditRepositoryR :: UUID -> Handler RepHtml
 getEditRepositoryR uuid = bootstrap (Just Config) $ do
diff --git a/Logs/Group.hs b/Logs/Group.hs
index a58eafe928..56363f8572 100644
--- a/Logs/Group.hs
+++ b/Logs/Group.hs
@@ -68,9 +68,7 @@ makeGroupMap byuuid = GroupMap byuuid bygroup
 		explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s)
 
 {- If a repository is in exactly one standard group, returns it. -}
-getStandardGroup :: UUID -> GroupMap -> Maybe StandardGroup
-getStandardGroup u m = maybe Nothing go $ u `M.lookup` groupsByUUID m
-	where
-		go s = case catMaybes $ map toStandardGroup $ S.toList s of
-			[g] -> Just g
-			_ -> Nothing
+getStandardGroup :: S.Set Group -> Maybe StandardGroup
+getStandardGroup s = case catMaybes $ map toStandardGroup $ S.toList s of
+	[g] -> Just g
+	_ -> Nothing
diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs
index 840c361559..9bb915983a 100644
--- a/Logs/PreferredContent.hs
+++ b/Logs/PreferredContent.hs
@@ -89,9 +89,8 @@ makeMatcher groupmap u s
 {- Standard matchers are pre-defined for some groups. If none is defined,
  - or a repository is in multiple groups with standard matchers, match all. -}
 standardMatcher :: GroupMap -> UUID -> Utility.Matcher.Matcher MatchFiles
-standardMatcher m u = maybe matchAll use (getStandardGroup u m)
-	where
-		use = makeMatcher m u . preferredContent
+standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $
+	getStandardGroup =<< u `M.lookup` groupsByUUID m
 
 matchAll :: Utility.Matcher.Matcher MatchFiles
 matchAll = Utility.Matcher.generate []
diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs
index 151fc3304d..32e2cb3af2 100644
--- a/Types/StandardGroups.hs
+++ b/Types/StandardGroups.hs
@@ -25,9 +25,9 @@ toStandardGroup _ = Nothing
 
 descStandardGroup :: StandardGroup -> String
 descStandardGroup ClientGroup = "client: a repository on your computer"
-descStandardGroup TransferGroup = "transfer: distributes data to clients"
-descStandardGroup ArchiveGroup = "archive: collect content that is not archived elsewhere"
-descStandardGroup BackupGroup = "backup: collects all content"
+descStandardGroup TransferGroup = "transfer: distributes files to clients"
+descStandardGroup ArchiveGroup = "archive: collects files that are not archived elsewhere"
+descStandardGroup BackupGroup = "backup: collects all files"
 
 {- See doc/preferred_content.mdwn for explanations of these expressions. -}
 preferredContent :: StandardGroup -> String