From 39be7eea40aaa3eb985ef8d8c12508d7ee0fd7ae Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Oct 2012 16:04:28 -0400 Subject: [PATCH] add standard group selector to repo edit form --- Assistant/WebApp/Configurators/Edit.hs | 9 +++++++++ Assistant/WebApp/Configurators/Local.hs | 2 +- Assistant/WebApp/Configurators/S3.hs | 2 +- Assistant/WebApp/Configurators/Ssh.hs | 2 +- Logs/Group.hs | 10 ++++++++++ Logs/PreferredContent.hs | 9 +++------ {Annex => Types}/StandardGroups.hs | 9 ++++++++- 7 files changed, 33 insertions(+), 10 deletions(-) rename {Annex => Types}/StandardGroups.hs (72%) diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 8deb2d8d03..2a688b329f 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index e3ba914279..02c9be12f2 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/S3.hs b/Assistant/WebApp/Configurators/S3.hs index 3c6fc5d907..04dffe7509 100644 --- a/Assistant/WebApp/Configurators/S3.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index d3a281b4b4..b440944e37 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/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) diff --git a/Logs/Group.hs b/Logs/Group.hs index 09d431e63a..a58eafe928 100644 --- a/Logs/Group.hs +++ b/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 diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index ed6dbb43e8..840c361559 100644 --- a/Logs/PreferredContent.hs +++ b/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 = - maybe matchAll findmatcher $ u `M.lookup` groupsByUUID groupmap +standardMatcher m u = maybe matchAll use (getStandardGroup u m) where - findmatcher s = case catMaybes $ map toStandardGroup $ S.toList s of - [g] -> makeMatcher groupmap u $ preferredContent g - _ -> matchAll + use = makeMatcher m u . preferredContent matchAll :: Utility.Matcher.Matcher MatchFiles matchAll = Utility.Matcher.generate [] diff --git a/Annex/StandardGroups.hs b/Types/StandardGroups.hs similarity index 72% rename from Annex/StandardGroups.hs rename to Types/StandardGroups.hs index 7c47cc628c..151fc3304d 100644 --- a/Annex/StandardGroups.hs +++ b/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/*"