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 Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.Set as S
|
||||||
|
|
||||||
|
data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data RepoConfig = RepoConfig
|
data RepoConfig = RepoConfig
|
||||||
{ repoDescription :: Text
|
{ repoDescription :: Text
|
||||||
, repoGroup :: Maybe StandardGroup
|
, repoGroup :: RepoGroup
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
|
editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
|
||||||
editRepositoryAForm def = RepoConfig
|
editRepositoryAForm def = RepoConfig
|
||||||
<$> areq textField "Description" (Just $ repoDescription def)
|
<$> areq textField "Description" (Just $ repoDescription def)
|
||||||
<*> aopt (selectFieldList standardgroups) "Repository group" (Just $ repoGroup def)
|
<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
|
||||||
where
|
where
|
||||||
standardgroups :: [(Text, StandardGroup)]
|
standardgroups :: [(Text, RepoGroup)]
|
||||||
standardgroups = map (\g -> (T.pack $ descStandardGroup g , g))
|
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
|
||||||
[minBound :: StandardGroup .. maxBound :: StandardGroup]
|
[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 -> Annex RepoConfig
|
||||||
getRepoConfig uuid = RepoConfig
|
getRepoConfig uuid = RepoConfig
|
||||||
<$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap)
|
<$> (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 -> Handler RepHtml
|
||||||
getEditRepositoryR uuid = bootstrap (Just Config) $ do
|
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)
|
explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s)
|
||||||
|
|
||||||
{- If a repository is in exactly one standard group, returns it. -}
|
{- If a repository is in exactly one standard group, returns it. -}
|
||||||
getStandardGroup :: UUID -> GroupMap -> Maybe StandardGroup
|
getStandardGroup :: S.Set Group -> Maybe StandardGroup
|
||||||
getStandardGroup u m = maybe Nothing go $ u `M.lookup` groupsByUUID m
|
getStandardGroup s = case catMaybes $ map toStandardGroup $ S.toList s of
|
||||||
where
|
[g] -> Just g
|
||||||
go s = case catMaybes $ map toStandardGroup $ S.toList s of
|
_ -> Nothing
|
||||||
[g] -> Just g
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
|
@ -89,9 +89,8 @@ makeMatcher groupmap u s
|
||||||
{- Standard matchers are pre-defined for some groups. If none is defined,
|
{- Standard matchers are pre-defined for some groups. If none is defined,
|
||||||
- or a repository is in multiple groups with standard matchers, match all. -}
|
- or a repository is in multiple groups with standard matchers, match all. -}
|
||||||
standardMatcher :: GroupMap -> UUID -> Utility.Matcher.Matcher MatchFiles
|
standardMatcher :: GroupMap -> UUID -> Utility.Matcher.Matcher MatchFiles
|
||||||
standardMatcher m u = maybe matchAll use (getStandardGroup u m)
|
standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $
|
||||||
where
|
getStandardGroup =<< u `M.lookup` groupsByUUID m
|
||||||
use = makeMatcher m u . preferredContent
|
|
||||||
|
|
||||||
matchAll :: Utility.Matcher.Matcher MatchFiles
|
matchAll :: Utility.Matcher.Matcher MatchFiles
|
||||||
matchAll = Utility.Matcher.generate []
|
matchAll = Utility.Matcher.generate []
|
||||||
|
|
|
@ -25,9 +25,9 @@ toStandardGroup _ = Nothing
|
||||||
|
|
||||||
descStandardGroup :: StandardGroup -> String
|
descStandardGroup :: StandardGroup -> String
|
||||||
descStandardGroup ClientGroup = "client: a repository on your computer"
|
descStandardGroup ClientGroup = "client: a repository on your computer"
|
||||||
descStandardGroup TransferGroup = "transfer: distributes data to clients"
|
descStandardGroup TransferGroup = "transfer: distributes files to clients"
|
||||||
descStandardGroup ArchiveGroup = "archive: collect content that is not archived elsewhere"
|
descStandardGroup ArchiveGroup = "archive: collects files that are not archived elsewhere"
|
||||||
descStandardGroup BackupGroup = "backup: collects all content"
|
descStandardGroup BackupGroup = "backup: collects all files"
|
||||||
|
|
||||||
{- See doc/preferred_content.mdwn for explanations of these expressions. -}
|
{- See doc/preferred_content.mdwn for explanations of these expressions. -}
|
||||||
preferredContent :: StandardGroup -> String
|
preferredContent :: StandardGroup -> String
|
||||||
|
|
Loading…
Reference in a new issue