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