add standard group selector to repo edit form

Assistant/WebApp/Configurators/Edit.hs

@@ -16,6 +16,8 @@ import Assistant.WebApp.SideBar
 import Utility.Yesod
 import qualified Remote
 import Logs.UUID
+import Logs.Group
+import Types.StandardGroups
 
 import Yesod
 import Data.Text (Text)
@@ -24,16 +26,23 @@ import qualified Data.Map as M
 
 data RepoConfig = RepoConfig
 	{ repoDescription :: Text
+	, repoGroup :: Maybe StandardGroup
 	}
 	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)
+	where
+		standardgroups :: [(Text, StandardGroup)]
+		standardgroups = map (\g -> (T.pack $ descStandardGroup g , g))
+			[minBound :: StandardGroup .. maxBound :: StandardGroup]
 
 getRepoConfig :: UUID -> Annex RepoConfig
 getRepoConfig uuid = RepoConfig
 	<$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap)
+	<*> (getStandardGroup uuid <$> groupMap)
 
 getEditRepositoryR :: UUID -> Handler RepHtml
 getEditRepositoryR uuid = bootstrap (Just Config) $ do

Assistant/WebApp/Configurators/Local.hs

@@ -29,7 +29,7 @@ import Utility.DataUnits
 import Utility.Network
 import Remote (prettyListUUIDs)
 import Annex.UUID
-import Annex.StandardGroups
+import Types.StandardGroups
 import Logs.PreferredContent
 
 import Yesod

Assistant/WebApp/Configurators/S3.hs

@@ -21,7 +21,7 @@ import qualified Remote.S3 as S3
 import Logs.Remote
 import qualified Remote
 import Types.Remote (RemoteConfig)
-import Annex.StandardGroups
+import Types.StandardGroups
 import Logs.PreferredContent
 
 import Yesod

Assistant/WebApp/Configurators/Ssh.hs

@@ -20,7 +20,7 @@ import Utility.Rsync (rsyncUrlIsShell)
 import Logs.Remote
 import Remote
 import Logs.PreferredContent
-import Annex.StandardGroups
+import Types.StandardGroups
 
 import Yesod
 import Data.Text (Text)

Logs/Group.hs

@@ -10,6 +10,7 @@ module Logs.Group (
 	groupSet,
 	lookupGroups,
 	groupMap,
+	getStandardGroup
 ) where
 
 import qualified Data.Map as M
@@ -21,6 +22,7 @@ import qualified Annex.Branch
 import qualified Annex
 import Logs.UUIDBased
 import Types.Group
+import Types.StandardGroups
 
 {- Filename of group.log. -}
 groupLog :: FilePath
@@ -64,3 +66,11 @@ makeGroupMap byuuid = GroupMap byuuid bygroup
 		bygroup = M.fromListWith S.union $
 			concat $ map explode $ M.toList byuuid
 		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

Logs/PreferredContent.hs

@@ -29,7 +29,7 @@ import Annex.UUID
 import Git.FilePath
 import Types.Group
 import Logs.Group
-import Annex.StandardGroups
+import Types.StandardGroups
 
 {- Filename of preferred-content.log. -}
 preferredContentLog :: FilePath
@@ -89,12 +89,9 @@ 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 groupmap u = 
+standardMatcher m u = maybe matchAll use (getStandardGroup u m)
-	maybe matchAll findmatcher $ u `M.lookup` groupsByUUID groupmap
 	where
-		findmatcher s = case catMaybes $ map toStandardGroup $ S.toList s of
+		use = makeMatcher m u . preferredContent
-			[g] -> makeMatcher groupmap u $ preferredContent g
-			_ -> matchAll
 
 matchAll :: Utility.Matcher.Matcher MatchFiles
 matchAll = Utility.Matcher.generate []

Types/StandardGroups.hs

@@ -5,9 +5,10 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Annex.StandardGroups where
+module Types.StandardGroups where
 
 data StandardGroup = ClientGroup | TransferGroup | ArchiveGroup | BackupGroup
+	deriving (Eq, Ord, Enum, Bounded, Show)
 
 fromStandardGroup :: StandardGroup -> String
 fromStandardGroup ClientGroup = "client"
@@ -22,6 +23,12 @@ toStandardGroup "archive" = Just ArchiveGroup
 toStandardGroup "backup" = Just BackupGroup
 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"
+
 {- See doc/preferred_content.mdwn for explanations of these expressions. -}
 preferredContent :: StandardGroup -> String
 preferredContent ClientGroup = "exclude=*/archive/*"