Default roles for repos and turn user/anon collab tables into proj/repo fields

* Repo collab now supports basic default roles developer/user/guest like
  project collab does
* User/Anon collab for repos and projects are now stored as fields instead of
  in dedicated tables, there was never a need for dedicated tables but I didn't
  see that before
* Repo push op is now part of `ProjectOperation`
* `RepoRole` and related code has been entirely removed, only project roles
  remain and they're used for both repos and projects
* This is the first not-totally-trivial DB migration in Vervis, it's automatic
  but please be careful and report errors
This commit is contained in:
fr33domlover 2019-01-29 22:24:32 +00:00
parent 5cba838917
commit c0965a4c47
28 changed files with 243 additions and 558 deletions

View file

@ -60,44 +60,13 @@ GroupMember
UniqueGroupMember person group UniqueGroupMember person group
RepoRole
ident RlIdent
sharer SharerId
desc Text
UniqueRepoRole sharer ident
RepoRoleInherit
parent RepoRoleId
child RepoRoleId
UniqueRepoRoleInherit parent child
RepoAccess
role RepoRoleId
op RepoOperation
UniqueRepoAccess role op
RepoCollab RepoCollab
repo RepoId repo RepoId
person PersonId person PersonId
role RepoRoleId role ProjectRoleId Maybe
UniqueRepoCollab repo person UniqueRepoCollab repo person
RepoCollabAnon
repo RepoId
role RepoRoleId
UniqueRepoCollabAnon repo
RepoCollabUser
repo RepoId
role RepoRoleId
UniqueRepoCollabUser repo
ProjectRole ProjectRole
ident RlIdent ident RlIdent
sharer SharerId sharer SharerId
@ -124,18 +93,6 @@ ProjectCollab
UniqueProjectCollab project person UniqueProjectCollab project person
ProjectCollabAnon
project ProjectId
role ProjectRoleId
UniqueProjectCollabAnon project
ProjectCollabUser
project ProjectId
role ProjectRoleId
UniqueProjectCollabUser project
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Projects -- Projects
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -148,6 +105,8 @@ Project
workflow WorkflowId workflow WorkflowId
nextTicket Int nextTicket Int
wiki RepoId Maybe wiki RepoId Maybe
collabUser ProjectRoleId Maybe
collabAnon ProjectRoleId Maybe
UniqueProject ident sharer UniqueProject ident sharer
@ -158,6 +117,8 @@ Repo
project ProjectId Maybe project ProjectId Maybe
desc Text Maybe desc Text Maybe
mainBranch Text mainBranch Text
collabUser ProjectRoleId Maybe
collabAnon ProjectRoleId Maybe
UniqueRepo ident sharer UniqueRepo ident sharer

View file

@ -61,12 +61,6 @@
/g/#ShrIdent/m/!new GroupMemberNewR GET /g/#ShrIdent/m/!new GroupMemberNewR GET
/g/#ShrIdent/m/#ShrIdent GroupMemberR GET DELETE POST /g/#ShrIdent/m/#ShrIdent GroupMemberR GET DELETE POST
/s/#ShrIdent/rr RepoRolesR GET POST
/s/#ShrIdent/rr/!new RepoRoleNewR GET
/s/#ShrIdent/rr/#RlIdent RepoRoleR GET DELETE POST
/s/#ShrIdent/rr/#RlIdent/a RepoRoleOpsR GET POST
/s/#ShrIdent/rr/#RlIdent/a/!new RepoRoleOpNewR GET
/s/#ShrIdent/pr ProjectRolesR GET POST /s/#ShrIdent/pr ProjectRolesR GET POST
/s/#ShrIdent/pr/!new ProjectRoleNewR GET /s/#ShrIdent/pr/!new ProjectRoleNewR GET
/s/#ShrIdent/pr/#RlIdent ProjectRoleR GET DELETE POST /s/#ShrIdent/pr/#RlIdent ProjectRoleR GET DELETE POST

View file

@ -0,0 +1,13 @@
ProjectRole
Project
collabUser ProjectRoleId Maybe
collabAnon ProjectRoleId Maybe
ProjectCollabAnon
project ProjectId
role ProjectRoleId
ProjectCollabUser
project ProjectId
role ProjectRoleId

View file

@ -79,84 +79,16 @@ data ObjectAccessStatus =
NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed
deriving Eq deriving Eq
checkRepoAccess
:: MonadIO m
=> Maybe PersonId
-> RepoOperation
-> ShrIdent
-> RpIdent
-> ReaderT SqlBackend m ObjectAccessStatus
checkRepoAccess mpid op shr rp = do
mrid <- runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
Entity rid _repo <- MaybeT $ getBy $ UniqueRepo rp sid
return rid
case mrid of
Nothing -> return NoSuchObject
Just rid -> do
mra <- runMaybeT $ do
rlid <- do
case mpid of
Just pid ->
MaybeT (asCollab rid pid)
<|> MaybeT (asUser rid)
<|> MaybeT (asAnon rid)
Nothing -> MaybeT $ asAnon rid
MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
return $
case mra of
Nothing -> ObjectAccessDenied
Just _ -> ObjectAccessAllowed
where
asCollab rid pid =
fmap (repoCollabRole . entityVal) <$>
getBy (UniqueRepoCollab rid pid)
asUser rid =
fmap (repoCollabUserRole . entityVal) <$>
getBy (UniqueRepoCollabUser rid)
asAnon rid =
fmap (repoCollabAnonRole . entityVal) <$>
getBy (UniqueRepoCollabAnon rid)
roleHas role operation = getBy $ UniqueRepoAccess role operation
ancestorHas = flip getRepoRoleAncestorWithOpQ
data PersonRole = Developer | User | Guest | RoleID ProjectRoleId data PersonRole = Developer | User | Guest | RoleID ProjectRoleId
checkProjectAccess roleHasAccess
:: MonadIO m :: MonadIO m
=> Maybe PersonId => PersonRole
-> ProjectOperation -> ProjectOperation
-> ShrIdent -> ReaderT SqlBackend m Bool
-> PrjIdent roleHasAccess Developer _ = pure True
-> ReaderT SqlBackend m ObjectAccessStatus roleHasAccess User op = pure $ userAccess op
checkProjectAccess mpid op shr prj = do
mjid <- runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
Entity jid _project <- MaybeT $ getBy $ UniqueProject prj sid
return jid
case mjid of
Nothing -> return NoSuchObject
Just jid -> do
role <- do
case mpid of
Just pid -> fmap (fromMaybe User) $ runMaybeT
$ MaybeT (asCollab jid pid)
<|> MaybeT (asUser jid)
<|> MaybeT (asAnon jid)
Nothing -> fromMaybe Guest <$> asAnon jid
status <$> hasAccess role op
where where
asCollab jid pid =
fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$>
getBy (UniqueProjectCollab jid pid)
asUser jid =
fmap (RoleID . projectCollabUserRole . entityVal) <$>
getBy (UniqueProjectCollabUser jid)
asAnon jid =
fmap (RoleID . projectCollabAnonRole . entityVal) <$>
getBy (UniqueProjectCollabAnon jid)
roleHas role operation = getBy $ UniqueProjectAccess role operation
ancestorHas = flip getProjectRoleAncestorWithOpQ
userAccess ProjOpOpenTicket = True userAccess ProjOpOpenTicket = True
userAccess ProjOpAcceptTicket = False userAccess ProjOpAcceptTicket = False
userAccess ProjOpCloseTicket = False userAccess ProjOpCloseTicket = False
@ -168,11 +100,70 @@ checkProjectAccess mpid op shr prj = do
userAccess ProjOpUnassignTicket = False userAccess ProjOpUnassignTicket = False
userAccess ProjOpAddTicketDep = False userAccess ProjOpAddTicketDep = False
userAccess ProjOpRemoveTicketDep = False userAccess ProjOpRemoveTicketDep = False
hasAccess Developer _ = pure True userAccess ProjOpPush = False
hasAccess User op = pure $ userAccess op roleHasAccess Guest _ = pure False
hasAccess Guest _ = pure False roleHasAccess (RoleID rlid) op =
hasAccess (RoleID rlid) op =
fmap isJust . runMaybeT $ fmap isJust . runMaybeT $
MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op) MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
where
roleHas role operation = getBy $ UniqueProjectAccess role operation
ancestorHas = flip getProjectRoleAncestorWithOpQ
status :: Bool -> ObjectAccessStatus
status True = ObjectAccessAllowed status True = ObjectAccessAllowed
status False = ObjectAccessDenied status False = ObjectAccessDenied
checkRepoAccess
:: MonadIO m
=> Maybe PersonId
-> ProjectOperation
-> ShrIdent
-> RpIdent
-> ReaderT SqlBackend m ObjectAccessStatus
checkRepoAccess mpid op shr rp = do
mer <- runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueRepo rp sid
case mer of
Nothing -> return NoSuchObject
Just (Entity rid repo) -> do
role <- do
case mpid of
Just pid ->
fromMaybe User . (<|> asUser repo) <$> asCollab rid pid
Nothing -> pure $ fromMaybe Guest $ asAnon repo
status <$> roleHasAccess role op
where
asCollab rid pid =
fmap (maybe Developer RoleID . repoCollabRole . entityVal) <$>
getBy (UniqueRepoCollab rid pid)
asUser = fmap RoleID . repoCollabUser
asAnon = fmap RoleID . repoCollabAnon
checkProjectAccess
:: MonadIO m
=> Maybe PersonId
-> ProjectOperation
-> ShrIdent
-> PrjIdent
-> ReaderT SqlBackend m ObjectAccessStatus
checkProjectAccess mpid op shr prj = do
mej <- runMaybeT $ do
Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueProject prj sid
case mej of
Nothing -> return NoSuchObject
Just (Entity jid project) -> do
role <- do
case mpid of
Just pid ->
fromMaybe User . (<|> asUser project) <$>
asCollab jid pid
Nothing -> pure $ fromMaybe Guest $ asAnon project
status <$> roleHasAccess role op
where
asCollab jid pid =
fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$>
getBy (UniqueProjectCollab jid pid)
asUser = fmap RoleID . projectCollabUser
asAnon = fmap RoleID . projectCollabAnon

View file

@ -14,9 +14,7 @@
-} -}
module Vervis.Field.Role module Vervis.Field.Role
( newRepoRoleIdentField ( newProjectRoleIdentField
, newRepoOpField
, newProjectRoleIdentField
, newProjectOpField , newProjectOpField
) )
where where
@ -38,39 +36,6 @@ import Vervis.Model.Role
roleIdentField :: Field Handler RlIdent roleIdentField :: Field Handler RlIdent
roleIdentField = convertField text2rl rl2text textField roleIdentField = convertField text2rl rl2text textField
newRepoRoleIdentField :: SharerId -> Field Handler RlIdent
newRepoRoleIdentField sid = checkUniqueCI roleIdentField
where
checkUniqueCI :: Field Handler RlIdent -> Field Handler RlIdent
checkUniqueCI = checkM $ \ rl -> do
sames <- runDB $ select $ from $ \ role -> do
where_ $
role ^. RepoRoleSharer ==. val sid &&.
lower_ (role ^. RepoRoleIdent) ==. lower_ (val rl)
limit 1
return ()
return $ if null sames
then Right rl
else Left ("This role name is already in use" :: Text)
newRepoOpField :: AppDB RepoRoleId -> Field Handler RepoOperation
newRepoOpField getrid = checkOpNew getrid opField
where
opField :: Field Handler RepoOperation
opField = selectField optionsEnum
checkOpNew
:: AppDB RepoRoleId
-> Field Handler RepoOperation
-> Field Handler RepoOperation
checkOpNew getrid = checkM $ \ op -> do
ma <- runDB $ do
rid <- getrid
getBy $ UniqueRepoAccess rid op
return $ case ma of
Nothing -> Right op
Just _ -> Left ("Role already has this operation" :: Text)
newProjectRoleIdentField :: SharerId -> Field Handler RlIdent newProjectRoleIdentField :: SharerId -> Field Handler RlIdent
newProjectRoleIdentField sid = checkUniqueCI roleIdentField newProjectRoleIdentField sid = checkUniqueCI roleIdentField
where where

View file

@ -104,8 +104,8 @@ newProjectCollabAForm sid jid = NewProjectCollab
newProjectCollabForm :: SharerId -> ProjectId -> Form NewProjectCollab newProjectCollabForm :: SharerId -> ProjectId -> Form NewProjectCollab
newProjectCollabForm sid jid = renderDivs $ newProjectCollabAForm sid jid newProjectCollabForm sid jid = renderDivs $ newProjectCollabAForm sid jid
editProjectAForm :: Entity Project -> AForm Handler Project editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
editProjectAForm (Entity jid project) = Project editProjectAForm sid (Entity jid project) = Project
<$> pure (projectIdent project) <$> pure (projectIdent project)
<*> pure (projectSharer project) <*> pure (projectSharer project)
<*> aopt textField "Name" (Just $ projectName project) <*> aopt textField "Name" (Just $ projectName project)
@ -113,11 +113,17 @@ editProjectAForm (Entity jid project) = Project
<*> pure (projectWorkflow project) <*> pure (projectWorkflow project)
<*> pure (projectNextTicket project) <*> pure (projectNextTicket project)
<*> aopt selectWiki "Wiki" (Just $ projectWiki project) <*> aopt selectWiki "Wiki" (Just $ projectWiki project)
<*> aopt selectRole "User role" (Just $ projectCollabUser project)
<*> aopt selectRole "Guest role" (Just $ projectCollabAnon project)
where where
selectWiki = selectWiki =
selectField $ selectField $
optionsPersistKey [RepoProject ==. Just jid] [] $ optionsPersistKey [RepoProject ==. Just jid] [] $
rp2text . repoIdent rp2text . repoIdent
selectRole =
selectField $
optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . projectRoleIdent
editProjectForm :: Entity Project -> Form Project editProjectForm :: SharerId -> Entity Project -> Form Project
editProjectForm p = renderDivs $ editProjectAForm p editProjectForm s j = renderDivs $ editProjectAForm s j

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -39,7 +39,7 @@ data NewRepo = NewRepo
, nrpVcs :: VersionControlSystem , nrpVcs :: VersionControlSystem
, nrpProj :: Maybe ProjectId , nrpProj :: Maybe ProjectId
, nrpDesc :: Maybe Text , nrpDesc :: Maybe Text
, nrpRole :: RepoRoleId , nrpRole :: Maybe ProjectRoleId
} }
newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler NewRepo newRepoAForm :: SharerId -> Maybe ProjectId -> AForm Handler NewRepo
@ -48,7 +48,7 @@ newRepoAForm sid mjid = NewRepo
<*> areq (selectFieldList vcsList) "Version control system*" Nothing <*> areq (selectFieldList vcsList) "Version control system*" Nothing
<*> aopt (selectProjectForNew sid) "Project" (Just mjid) <*> aopt (selectProjectForNew sid) "Project" (Just mjid)
<*> aopt textField "Description" Nothing <*> aopt textField "Description" Nothing
<*> areq selectRole "Your role*" Nothing <*> aopt selectRole "Custom role" Nothing
where where
vcsList :: [(Text, VersionControlSystem)] vcsList :: [(Text, VersionControlSystem)]
vcsList = vcsList =
@ -57,47 +57,54 @@ newRepoAForm sid mjid = NewRepo
] ]
selectRole = selectRole =
selectField $ selectField $
optionsPersistKey [RepoRoleSharer ==. sid] [] $ optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . repoRoleIdent rl2text . projectRoleIdent
newRepoForm :: SharerId -> Maybe ProjectId -> Form NewRepo newRepoForm :: SharerId -> Maybe ProjectId -> Form NewRepo
newRepoForm sid mjid = renderDivs $ newRepoAForm sid mjid newRepoForm sid mjid = renderDivs $ newRepoAForm sid mjid
data NewRepoCollab = NewRepoCollab data NewRepoCollab = NewRepoCollab
{ ncPerson :: PersonId { ncPerson :: PersonId
, ncRole :: RepoRoleId , ncRole :: Maybe ProjectRoleId
} }
newRepoCollabAForm newRepoCollabAForm
:: SharerId -> Maybe ProjectId -> RepoId -> AForm Handler NewRepoCollab :: SharerId -> Maybe ProjectId -> RepoId -> AForm Handler NewRepoCollab
newRepoCollabAForm sid mjid rid = NewRepoCollab newRepoCollabAForm sid mjid rid = NewRepoCollab
<$> areq (selectPerson mjid) "Person*" Nothing <$> areq (selectPerson mjid) "Person*" Nothing
<*> areq selectRole "Role*" Nothing <*> aopt selectRole "Custom role" Nothing
where where
selectPerson Nothing = selectCollabFromAll rid selectPerson Nothing = selectCollabFromAll rid
selectPerson (Just jid) = selectCollabFromProject jid rid selectPerson (Just jid) = selectCollabFromProject jid rid
selectRole = selectRole =
selectField $ selectField $
optionsPersistKey [RepoRoleSharer ==. sid] [] $ optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . repoRoleIdent rl2text . projectRoleIdent
newRepoCollabForm newRepoCollabForm
:: SharerId -> Maybe ProjectId -> RepoId -> Form NewRepoCollab :: SharerId -> Maybe ProjectId -> RepoId -> Form NewRepoCollab
newRepoCollabForm sid mjid rid = renderDivs $ newRepoCollabAForm sid mjid rid newRepoCollabForm sid mjid rid = renderDivs $ newRepoCollabAForm sid mjid rid
editRepoAForm :: Entity Repo -> AForm Handler Repo editRepoAForm :: SharerId -> Entity Repo -> AForm Handler Repo
editRepoAForm (Entity rid repo) = Repo editRepoAForm sid (Entity rid repo) = Repo
<$> pure (repoIdent repo) <$> pure (repoIdent repo)
<*> pure (repoSharer repo) <*> pure (repoSharer repo)
<*> pure (repoVcs repo) <*> pure (repoVcs repo)
<*> aopt selectProject' "Project" (Just $ repoProject repo) <*> aopt selectProject' "Project" (Just $ repoProject repo)
<*> aopt textField "Description" (Just $ repoDesc repo) <*> aopt textField "Description" (Just $ repoDesc repo)
<*> let b = repoMainBranch repo <*> (let b = repoMainBranch repo
in case repoVcs repo of in case repoVcs repo of
VCSDarcs -> pure b VCSDarcs -> pure b
VCSGit -> areq textField "Main branch*" (Just b) VCSGit -> areq textField "Main branch*" (Just b)
)
<*> aopt selectRole "User role" (Just $ repoCollabUser repo)
<*> aopt selectRole "Guest role" (Just $ repoCollabAnon repo)
where where
selectProject' = selectProjectForExisting (repoSharer repo) rid selectProject' = selectProjectForExisting (repoSharer repo) rid
selectRole =
selectField $
optionsPersistKey [ProjectRoleSharer ==. sid] [] $
rl2text . projectRoleIdent
editRepoForm :: Entity Repo -> Form Repo editRepoForm :: SharerId -> Entity Repo -> Form Repo
editRepoForm r = renderDivs $ editRepoAForm r editRepoForm s r = renderDivs $ editRepoAForm s r

View file

@ -14,10 +14,7 @@
-} -}
module Vervis.Form.Role module Vervis.Form.Role
( NewRepoRole (..) ( NewProjectRole (..)
, newRepoRoleForm
, newRepoRoleOpForm
, NewProjectRole (..)
, newProjectRoleForm , newProjectRoleForm
, newProjectRoleOpForm , newProjectRoleOpForm
) )
@ -36,25 +33,6 @@ import Vervis.Model
import Vervis.Model.Ident (RlIdent) import Vervis.Model.Ident (RlIdent)
import Vervis.Model.Role import Vervis.Model.Role
data NewRepoRole = NewRepoRole
{ nrrIdent :: RlIdent
, nrrDesc :: Text
}
newRepoRoleAForm :: SharerId -> AForm Handler NewRepoRole
newRepoRoleAForm sid = NewRepoRole
<$> areq (newRepoRoleIdentField sid) "Name*" Nothing
<*> areq textField "Description" Nothing
newRepoRoleForm :: SharerId -> Form NewRepoRole
newRepoRoleForm sid = renderDivs $ newRepoRoleAForm sid
newRepoRoleOpAForm :: AppDB RepoRoleId -> AForm Handler RepoOperation
newRepoRoleOpAForm getrid = areq (newRepoOpField getrid) "Operation*" Nothing
newRepoRoleOpForm :: AppDB RepoRoleId -> Form RepoOperation
newRepoRoleOpForm getrid = renderDivs $ newRepoRoleOpAForm getrid
data NewProjectRole = NewProjectRole data NewProjectRole = NewProjectRole
{ nprIdent :: RlIdent { nprIdent :: RlIdent
, nprDesc :: Text , nprDesc :: Text

View file

@ -186,12 +186,6 @@ instance Yesod App where
(ClaimRequestsPersonR , _ ) -> personAny (ClaimRequestsPersonR , _ ) -> personAny
(RepoRolesR shr , _ ) -> personOrGroupAdmin shr
(RepoRoleNewR shr , _ ) -> personOrGroupAdmin shr
(RepoRoleR shr _rl , _ ) -> personOrGroupAdmin shr
(RepoRoleOpsR shr _rl , _ ) -> personOrGroupAdmin shr
(RepoRoleOpNewR shr _rl , _ ) -> personOrGroupAdmin shr
(ProjectRolesR shr , _ ) -> personOrGroupAdmin shr (ProjectRolesR shr , _ ) -> personOrGroupAdmin shr
(ProjectRoleNewR shr , _ ) -> personOrGroupAdmin shr (ProjectRoleNewR shr , _ ) -> personOrGroupAdmin shr
(ProjectRoleR shr _rl , _ ) -> personOrGroupAdmin shr (ProjectRoleR shr _rl , _ ) -> personOrGroupAdmin shr
@ -244,7 +238,6 @@ instance Yesod App where
(TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j (TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j
(ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j (ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j
(ClaimRequestNewR s j _ , _ ) -> projOp ProjOpRequestTicket s j (ClaimRequestNewR s j _ , _ ) -> projOp ProjOpRequestTicket s j
(TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j
(TicketDiscussionR _ _ _ , True) -> personAny (TicketDiscussionR _ _ _ , True) -> personAny
(TicketMessageR _ _ _ _ , True) -> personAny (TicketMessageR _ _ _ _ , True) -> personAny
(TicketTopReplyR _ _ _ , _ ) -> personAny (TicketTopReplyR _ _ _ , _ ) -> personAny
@ -641,6 +634,7 @@ instance YesodBreadcrumbs App where
PeopleR -> ("People", Just HomeR) PeopleR -> ("People", Just HomeR)
PersonNewR -> ("New", Just PeopleR) PersonNewR -> ("New", Just PeopleR)
PersonR shar -> (shr2text shar, Just PeopleR) PersonR shar -> (shr2text shar, Just PeopleR)
PersonActivitiesR shr -> ("Activities", Just $ PersonR shr)
GroupsR -> ("Groups", Just HomeR) GroupsR -> ("Groups", Just HomeR)
GroupNewR -> ("New", Just GroupsR) GroupNewR -> ("New", Just GroupsR)
@ -659,14 +653,6 @@ instance YesodBreadcrumbs App where
, Just HomeR , Just HomeR
) )
RepoRolesR shr -> ("Repo Roles", Just $ SharerR shr)
RepoRoleNewR shr -> ("New", Just $ RepoRolesR shr)
RepoRoleR shr rl -> (rl2text rl, Just $ RepoRolesR shr)
RepoRoleOpsR shr rl -> ( "Operations"
, Just $ RepoRoleR shr rl
)
RepoRoleOpNewR shr rl -> ("New", Just $ RepoRoleOpsR shr rl)
ProjectRolesR shr -> ( "Project Roles" ProjectRolesR shr -> ( "Project Roles"
, Just $ SharerR shr , Just $ SharerR shr
) )
@ -709,6 +695,7 @@ instance YesodBreadcrumbs App where
DarcsDownloadR _ _ _ -> ("", Nothing) DarcsDownloadR _ _ _ -> ("", Nothing)
GitRefDiscoverR _ _ -> ("", Nothing) GitRefDiscoverR _ _ -> ("", Nothing)
GitUploadRequestR _ _ -> ("", Nothing)
ProjectsR shar -> ("Projects", Just $ PersonR shar) ProjectsR shar -> ("Projects", Just $ PersonR shar)
ProjectNewR shar -> ("New", Just $ ProjectsR shar) ProjectNewR shar -> ("New", Just $ ProjectsR shar)

View file

@ -81,6 +81,8 @@ postProjectsR shr = do
, projectWorkflow = npWflow np , projectWorkflow = npWflow np
, projectNextTicket = 1 , projectNextTicket = 1
, projectWiki = Nothing , projectWiki = Nothing
, projectCollabAnon = Nothing
, projectCollabUser = Nothing
} }
jid <- insert project jid <- insert project
let collab = ProjectCollab let collab = ProjectCollab
@ -120,10 +122,11 @@ getProjectR shar proj = do
putProjectR :: ShrIdent -> PrjIdent -> Handler Html putProjectR :: ShrIdent -> PrjIdent -> Handler Html
putProjectR shr prj = do putProjectR shr prj = do
ep@(Entity jid project) <- runDB $ do (sid, ep@(Entity jid _)) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr Entity sid _sharer <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueProject prj sid eproj <- getBy404 $ UniqueProject prj sid
((result, widget), enctype) <- runFormPost $ editProjectForm ep return (sid, eproj)
((result, widget), enctype) <- runFormPost $ editProjectForm sid ep
case result of case result of
FormSuccess project' -> do FormSuccess project' -> do
runDB $ replace jid project' runDB $ replace jid project'
@ -145,10 +148,11 @@ postProjectR shr prj = do
getProjectEditR :: ShrIdent -> PrjIdent -> Handler Html getProjectEditR :: ShrIdent -> PrjIdent -> Handler Html
getProjectEditR shr prj = do getProjectEditR shr prj = do
ep <- runDB $ do (sid, ep) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr Entity sid _sharer <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueProject prj sid ep <- getBy404 $ UniqueProject prj sid
((_result, widget), enctype) <- runFormPost $ editProjectForm ep return (sid, ep)
((_result, widget), enctype) <- runFormPost $ editProjectForm sid ep
defaultLayout $(widgetFile "project/edit") defaultLayout $(widgetFile "project/edit")
getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -134,6 +134,8 @@ postReposR user = do
, repoProject = nrpProj nrp , repoProject = nrpProj nrp
, repoDesc = nrpDesc nrp , repoDesc = nrpDesc nrp
, repoMainBranch = "master" , repoMainBranch = "master"
, repoCollabUser = Nothing
, repoCollabAnon = Nothing
} }
rid <- insert repo rid <- insert repo
let collab = RepoCollab let collab = RepoCollab
@ -182,13 +184,13 @@ putRepoR shr rp = do
return $ (== rid) <$> projectWiki project return $ (== rid) <$> projectWiki project
return $ case mwiki of return $ case mwiki of
Just (Just True) -> Nothing Just (Just True) -> Nothing
_ -> Just er _ -> Just (sid, er)
case mer of case mer of
Nothing -> do Nothing -> do
setMessage "Repo used as a wiki, can't move between projects." setMessage "Repo used as a wiki, can't move between projects."
redirect $ RepoR shr rp redirect $ RepoR shr rp
Just er@(Entity rid _) -> do Just (sid, er@(Entity rid _)) -> do
((result, widget), enctype) <- runFormPost $ editRepoForm er ((result, widget), enctype) <- runFormPost $ editRepoForm sid er
case result of case result of
FormSuccess repository' -> do FormSuccess repository' -> do
runDB $ replace rid repository' runDB $ replace rid repository'
@ -230,10 +232,11 @@ postRepoR shar repo = do
getRepoEditR :: ShrIdent -> RpIdent -> Handler Html getRepoEditR :: ShrIdent -> RpIdent -> Handler Html
getRepoEditR shr rp = do getRepoEditR shr rp = do
er <- runDB $ do (sid, er) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueRepo rp s er <- getBy404 $ UniqueRepo rp sid
((_result, widget), enctype) <- runFormPost $ editRepoForm er return (sid, er)
((_result, widget), enctype) <- runFormPost $ editRepoForm sid er
defaultLayout $(widgetFile "repo/edit") defaultLayout $(widgetFile "repo/edit")
getRepoSourceR :: ShrIdent -> RpIdent -> [Text] -> Handler Html getRepoSourceR :: ShrIdent -> RpIdent -> [Text] -> Handler Html
@ -273,13 +276,15 @@ getRepoDevsR shr rp = do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity r _ <- getBy404 $ UniqueRepo rp s Entity r _ <- getBy404 $ UniqueRepo rp s
return r return r
select $ from $ \ (collab, person, sharer, role) -> do select $ from $ \ (collab `InnerJoin`
where_ $ person `InnerJoin`
collab ^. RepoCollabRepo ==. val rid &&. sharer `LeftOuterJoin`
collab ^. RepoCollabPerson ==. person ^. PersonId &&. role) -> do
person ^. PersonIdent ==. sharer ^. SharerId &&. on $ collab ^. RepoCollabRole ==. role ?. ProjectRoleId
collab ^. RepoCollabRole ==. role ^. RepoRoleId on $ person ^. PersonIdent ==. sharer ^. SharerId
return (sharer, role ^. RepoRoleIdent) on $ collab ^. RepoCollabPerson ==. person ^. PersonId
where_ $ collab ^. RepoCollabRepo ==. val rid
return (sharer, role ?. ProjectRoleIdent)
defaultLayout $(widgetFile "repo/collab/list") defaultLayout $(widgetFile "repo/collab/list")
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
@ -319,7 +324,7 @@ getRepoDevNewR shr rp = do
getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html getRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
getRepoDevR shr rp dev = do getRepoDevR shr rp dev = do
rl <- runDB $ do mrl <- runDB $ do
rid <- do rid <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity r _ <- getBy404 $ UniqueRepo rp s Entity r _ <- getBy404 $ UniqueRepo rp s
@ -329,8 +334,7 @@ getRepoDevR shr rp dev = do
Entity p _ <- getBy404 $ UniquePersonIdent s Entity p _ <- getBy404 $ UniquePersonIdent s
return p return p
Entity _cid collab <- getBy404 $ UniqueRepoCollab rid pid Entity _cid collab <- getBy404 $ UniqueRepoCollab rid pid
role <- getJust $ repoCollabRole collab fmap projectRoleIdent <$> traverse getJust (repoCollabRole collab)
return $ repoRoleIdent role
defaultLayout $(widgetFile "repo/collab/one") defaultLayout $(widgetFile "repo/collab/one")
deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -14,16 +14,7 @@
-} -}
module Vervis.Handler.Role module Vervis.Handler.Role
( getRepoRolesR ( getProjectRolesR
, postRepoRolesR
, getRepoRoleNewR
, getRepoRoleR
, deleteRepoRoleR
, postRepoRoleR
, getRepoRoleOpsR
, postRepoRoleOpsR
, getRepoRoleOpNewR
, getProjectRolesR
, postProjectRolesR , postProjectRolesR
, getProjectRoleNewR , getProjectRoleNewR
, getProjectRoleR , getProjectRoleR
@ -56,106 +47,6 @@ import Vervis.Settings (widgetFile)
import Vervis.Widget (buttonW) import Vervis.Widget (buttonW)
import Vervis.Widget.Role import Vervis.Widget.Role
getRepoRolesR :: ShrIdent -> Handler Html
getRepoRolesR shr = do
--roles <- runDB $ do
-- Entity sid _ <- getBy404 $ UniqueSharer shr
-- selectList [RepoRoleSharer ==. sid] []
graph <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shr
getRepoRoleGraph sid
defaultLayout $(widgetFile "repo/role/graph")
postRepoRolesR :: ShrIdent -> Handler Html
postRepoRolesR shr = do
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
((result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
case result of
FormSuccess nrr -> do
runDB $ do
let role = RepoRole
{ repoRoleIdent = nrrIdent nrr
, repoRoleSharer = sid
, repoRoleDesc = nrrDesc nrr
}
insert_ role
redirect $ RepoRolesR shr
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/role/new")
FormFailure _l -> do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "repo/role/new")
getRepoRoleNewR :: ShrIdent -> Handler Html
getRepoRoleNewR shr = do
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
((_result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
defaultLayout $(widgetFile "repo/role/new")
getRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleR shr rl = do
Entity _rid role <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueRepoRole sid rl
defaultLayout $(widgetFile "repo/role/one")
deleteRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
deleteRepoRoleR shr rl = do
runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
delete rid
setMessage "Role deleted."
redirect $ RepoRolesR shr
postRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
postRepoRoleR shr rl = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "DELETE" -> deleteRepoRoleR shr rl
_ -> notFound
getRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleOpsR shr rl = do
ops <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
as <- selectList [RepoAccessRole ==. rid] []
return $ map (repoAccessOp . entityVal) as
defaultLayout $(widgetFile "repo/role/op/list")
postRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
postRepoRoleOpsR shr rl = do
let getrid = do
Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
case result of
FormSuccess op -> do
runDB $ do
rid <- getrid
let access = RepoAccess
{ repoAccessRole = rid
, repoAccessOp = op
}
insert_ access
redirect $ RepoRoleOpsR shr rl
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/role/op/new")
FormFailure _l -> do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "repo/role/op/new")
getRepoRoleOpNewR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleOpNewR shr rl = do
let getrid = do
Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
defaultLayout $(widgetFile "repo/role/op/new")
getProjectRolesR :: ShrIdent -> Handler Html getProjectRolesR :: ShrIdent -> Handler Html
getProjectRolesR shr = do getProjectRolesR shr = do
--roles <- runDB $ do --roles <- runDB $ do

View file

@ -45,6 +45,7 @@ import Database.Persist.Sql (SqlBackend, toSqlKey)
import Text.Email.Validate (unsafeEmailAddress) import Text.Email.Validate (unsafeEmailAddress)
import Web.PathPieces (toPathPiece) import Web.PathPieces (toPathPiece)
import qualified Database.Esqueleto as E
import qualified Database.Persist.Schema as U (addEntity, unsetFieldDefault) import qualified Database.Persist.Schema as U (addEntity, unsetFieldDefault)
import Vervis.Migration.Model import Vervis.Migration.Model
@ -136,6 +137,56 @@ changes =
, addFieldPrimRequired "Person" ("" :: Text) "about" , addFieldPrimRequired "Person" ("" :: Text) "about"
-- 26 -- 26
, setFieldMaybe "ProjectCollab" "role" , setFieldMaybe "ProjectCollab" "role"
-- 27
, removeField "RepoCollab" "role"
-- 28
, addFieldRefOptional "RepoCollab" Nothing "role" "ProjectRole"
-- 29
, removeEntity "RepoCollabAnon"
-- 30
, removeEntity "RepoCollabUser"
-- 31
, addFieldRefOptional "Repo" Nothing "collabUser" "ProjectRole"
-- 32
, addFieldRefOptional "Repo" Nothing "collabAnon" "ProjectRole"
-- 33
, addFieldRefOptional "Project" Nothing "collabUser" "ProjectRole"
-- 34
, addFieldRefOptional "Project" Nothing "collabAnon" "ProjectRole"
-- 35
, unchecked $ lift $ do
l <- E.select $ E.from $ \ (j `E.LeftOuterJoin`
jcu `E.LeftOuterJoin`
jca) -> do
E.on $
E.just (j E.^. Project2018Id) E.==.
jca E.?. ProjectCollabAnon2018Project
E.on $
E.just (j E.^. Project2018Id) E.==.
jcu E.?. ProjectCollabUser2018Project
E.where_ $ E.not_ $
E.isNothing (jcu E.?. ProjectCollabUser2018Project) E.&&.
E.isNothing (jca E.?. ProjectCollabAnon2018Project)
return
( j E.^. Project2018Id
, jca E.?. ProjectCollabAnon2018Role
, jcu E.?. ProjectCollabUser2018Role
)
for_ l $ \ (E.Value jid, E.Value malid, E.Value mulid) ->
update jid
[ Project2018CollabAnon =. malid
, Project2018CollabUser =. mulid
]
-- 36
, removeEntity "ProjectCollabAnon"
-- 37
, removeEntity "ProjectCollabUser"
-- 38
, removeEntity "RepoAccess"
-- 39
, removeEntity "RepoRoleInherit"
-- 40
, removeEntity "RepoRole"
] ]
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int)) migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2018 by fr33domlover <fr33domlover@riseup.net>. - Written in 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -14,7 +14,8 @@
-} -}
module Vervis.Migration.Model module Vervis.Migration.Model
( model_2016_08_04 ( EntityField (..)
, model_2016_08_04
, model_2016_09_01_just_workflow , model_2016_09_01_just_workflow
, Workflow2016Generic (..) , Workflow2016Generic (..)
, Workflow2016 , Workflow2016
@ -27,6 +28,7 @@ import Prelude
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Text (Text) import Data.Text (Text)
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Database.Persist.Class (EntityField)
import Database.Persist.Schema.Types (Entity) import Database.Persist.Schema.Types (Entity)
import Database.Persist.Schema.SQL () import Database.Persist.Schema.SQL ()
import Database.Persist.Sql (SqlBackend) import Database.Persist.Sql (SqlBackend)
@ -52,3 +54,6 @@ makeEntitiesMigration "2016"
model_2016_09_01_rest :: [Entity SqlBackend] model_2016_09_01_rest :: [Entity SqlBackend]
model_2016_09_01_rest = $(schema "2016_09_01_rest") model_2016_09_01_rest = $(schema "2016_09_01_rest")
makeEntitiesMigration "2018"
$(modelFile "migrations/2019_01_28_project_collabs.model")

View file

@ -64,11 +64,6 @@ instance Hashable MessageId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey hashWithSalt salt = hashWithSalt salt . fromSqlKey
hash = hash . fromSqlKey hash = hash . fromSqlKey
-- "Vervis.Role" uses a 'HashMap' where the key type is 'RepoRoleId'
instance Hashable RepoRoleId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey
hash = hash . fromSqlKey
-- "Vervis.Role" uses a 'HashMap' where the key type is 'ProjectRoleId' -- "Vervis.Role" uses a 'HashMap' where the key type is 'ProjectRoleId'
instance Hashable ProjectRoleId where instance Hashable ProjectRoleId where
hashWithSalt salt = hashWithSalt salt . fromSqlKey hashWithSalt salt = hashWithSalt salt . fromSqlKey

View file

@ -39,6 +39,7 @@ data ProjectOperation
| ProjOpUnassignTicket | ProjOpUnassignTicket
| ProjOpAddTicketDep | ProjOpAddTicketDep
| ProjOpRemoveTicketDep | ProjOpRemoveTicketDep
| ProjOpPush
deriving (Eq, Show, Read, Enum, Bounded) deriving (Eq, Show, Read, Enum, Bounded)
derivePersistField "ProjectOperation" derivePersistField "ProjectOperation"

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -18,8 +18,7 @@
-- helps identify patterns and commonly needed but missing tools, which can -- helps identify patterns and commonly needed but missing tools, which can
-- then be implemented and simplify the queries. -- then be implemented and simplify the queries.
module Vervis.Query module Vervis.Query
( getRepoRoleAncestorWithOpQ ( getProjectRoleAncestorWithOpQ
, getProjectRoleAncestorWithOpQ
) )
where where
@ -41,45 +40,6 @@ import Database.Persist.Graph.SQL
import Vervis.Model import Vervis.Model
import Vervis.Model.Role import Vervis.Model.Role
-- | Given a repo role and a repo operation, find an ancestor role which
-- has access to the operation.
getRepoRoleAncestorWithOpQ
:: MonadIO m
=> RepoOperation
-> RepoRoleId
-> ReaderT SqlBackend m (Maybe (Entity RepoAccess))
getRepoRoleAncestorWithOpQ op role = do
conn <- ask
let dbname = connEscapeName conn
eAcc = entityDef $ dummyFromField RepoAccessId
tAcc = dbname $ entityDB eAcc
qcols =
T.intercalate ", " $
map ((tAcc <>) . ("." <>)) $
entityColumnNames eAcc conn
field :: PersistEntity record => EntityField record typ -> Text
field = dbname . fieldDB . persistFieldDef
listToMaybe <$>
rawSqlWithGraph
Ancestors
role
RepoRoleInheritParent
RepoRoleInheritChild
(\ temp -> mconcat
[ "SELECT ??"
, " FROM ", dbname temp, " INNER JOIN ", tAcc
, " ON "
, dbname temp, ".", field RepoRoleInheritParent
, " = "
, tAcc, ".", field RepoAccessRole
, " WHERE "
, tAcc, ".", field RepoAccessOp
, " = ?"
, " LIMIT 1"
]
)
[toPersistValue op]
-- | Given a project role and a project operation, find an ancestor role which -- | Given a project role and a project operation, find an ancestor role which
-- has access to the operation. -- has access to the operation.
getProjectRoleAncestorWithOpQ getProjectRoleAncestorWithOpQ

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -14,8 +14,7 @@
-} -}
module Vervis.Role module Vervis.Role
( getRepoRoleGraph ( getProjectRoleGraph
, getProjectRoleGraph
) )
where where
@ -35,32 +34,6 @@ import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
getRepoRoleGraph :: SharerId -> AppDB (Gr RlIdent ())
getRepoRoleGraph sid = do
(roles, inhs) <- do
rrs <- P.selectList [RepoRoleSharer P.==. sid] []
rrhs <- select $ from $ \ (rr `InnerJoin` rrh) -> do
on $ rr ^. RepoRoleId ==. rrh ^. RepoRoleInheritParent
where_ $ rr ^. RepoRoleSharer ==. val sid
return rrh
return (rrs, rrhs)
let numbered = zip [1..] roles
nodes = map (second $ repoRoleIdent . entityVal) numbered
nodeMap = M.fromList $ map (swap . second entityKey) numbered
rridToNode rrid =
case M.lookup rrid nodeMap of
Nothing -> error "Role graph: Node not found in node map"
Just n -> n
edges =
map
( (\ (c, p) -> (c, p, ()))
. (rridToNode *** rridToNode)
. (repoRoleInheritChild &&& repoRoleInheritParent)
. entityVal
)
inhs
return $ mkGraph nodes edges
getProjectRoleGraph :: SharerId -> AppDB (Gr RlIdent ()) getProjectRoleGraph :: SharerId -> AppDB (Gr RlIdent ())
getProjectRoleGraph sid = do getProjectRoleGraph sid = do
(roles, inhs) <- do (roles, inhs) <- do

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -233,7 +233,7 @@ whenGitRepoExists = whenRepoExists "Git" $ isRepo . fromString
canPushTo :: ShrIdent -> RpIdent -> Channel Bool canPushTo :: ShrIdent -> RpIdent -> Channel Bool
canPushTo shr rp = do canPushTo shr rp = do
pid <- authId <$> askAuthDetails pid <- authId <$> askAuthDetails
oas <- runChanDB $ checkRepoAccess (Just pid) RepoOpPush shr rp oas <- runChanDB $ checkRepoAccess (Just pid) ProjOpPush shr rp
return $ return $
case oas of case oas of
ObjectAccessAllowed -> True ObjectAccessAllowed -> True

View file

@ -14,8 +14,7 @@
-} -}
module Vervis.Widget.Role module Vervis.Widget.Role
( repoRoleGraphW ( projectRoleGraphW
, projectRoleGraphW
) )
where where
@ -59,8 +58,5 @@ roleGraph link shr g = do
svg = renderDia SVG opts dia svg = renderDia SVG opts dia
toWidget $ preEscapedToHtml $ renderText svg toWidget $ preEscapedToHtml $ renderText svg
repoRoleGraphW :: Graph g => ShrIdent -> g RlIdent () -> Widget
repoRoleGraphW = roleGraph RepoRoleR
projectRoleGraphW :: Graph g => ShrIdent -> g RlIdent () -> Widget projectRoleGraphW :: Graph g => ShrIdent -> g RlIdent () -> Widget
projectRoleGraphW = roleGraph ProjectRoleR projectRoleGraphW = roleGraph ProjectRoleR

View file

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -31,10 +31,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<a href=@{KeysR}>SSH keys <a href=@{KeysR}>SSH keys
<li> <li>
<a href=@{RepoRolesR ident}>Repository roles <a href=@{ProjectRolesR ident}>Roles
<li>
<a href=@{ProjectRolesR ident}>Project roles
<li> <li>
<a href=@{ClaimRequestsPersonR}>Ticket claim requests <a href=@{ClaimRequestsPersonR}>Ticket claim requests

View file

@ -16,9 +16,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<tr> <tr>
<th>Collaborator <th>Collaborator
<th>Role <th>Role
$forall (Entity _sid sharer, Value rl) <- devs $forall (Entity _sid sharer, Value mrl) <- devs
<tr> <tr>
<td>^{personLinkW sharer} <td>^{personLinkW sharer}
<td>#{rl2text rl} <td>
$maybe rl <- mrl
#{rl2text rl}
$nothing
(Developer)
<a href=@{RepoDevNewR shr rp}>Add… <a href=@{RepoDevNewR shr rp}>Add…

View file

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -13,4 +13,7 @@ $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p> <p>
$maybe rl <- mrl
Role: #{rl2text rl} Role: #{rl2text rl}
$nothing
Role: (Developer)

View file

@ -1,24 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
<a href=@{RepoRoleNewR shr}>New…
^{repoRoleGraphW shr graph}
$#<ul>
$# $forall Entity _rid role <- roles
$# <li>
$# <a href=@{RepoRoleR shr $ repoRoleIdent role}>
$# #{rl2text $ repoRoleIdent role}

View file

@ -1,17 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{RepoRolesR shr} enctype=#{enctype}>
^{widget}
<input type=submit>

View file

@ -1,22 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
^{buttonW DELETE "Delete this role" (RepoRoleR shr rl)}
<p>
<a href=@{RepoRoleOpsR shr rl}>Operations
<p>
#{repoRoleDesc role}

View file

@ -1,21 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
<a href=@{RepoRoleOpNewR shr rl}>New…
<ul>
$forall op <- ops
<li>
#{show op}

View file

@ -1,17 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{RepoRoleOpsR shr rl} enctype=#{enctype}>
^{widget}
<input type=submit>