ui for selecting a repository group
This commit is contained in:
parent
39be7eea40
commit
4e2e08b45a
4 changed files with 28 additions and 17 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
getStandardGroup :: S.Set Group -> Maybe StandardGroup
|
||||
getStandardGroup s = case catMaybes $ map toStandardGroup $ S.toList s of
|
||||
[g] -> Just g
|
||||
_ -> Nothing
|
||||
|
|
|
@ -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 []
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue