ui for selecting a repository group

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

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

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 []

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