forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Put roles under sharers, now groups' roles can be managed too

Browse source
This commit is contained in:
fr33domlover 2016-06-06 19:41:22 +00:00
parent f2e4bb4291
commit 23c06c535a
14 changed files with 195 additions and 159 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
config/routes
View file

@ -50,17 +50,17 @@
/k/!new KeyNewR GET
/k/#KyIdent KeyR GET DELETE POST
/rr RepoRolesR GET POST
/rr/!new RepoRoleNewR GET
/rr/#RlIdent RepoRoleR GET DELETE POST
/rr/#RlIdent/a RepoRoleOpsR GET POST
/rr/#RlIdent/a/!new RepoRoleOpNewR GET
/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
/pr ProjectRolesR GET POST
/pr/!new ProjectRoleNewR GET
/pr/#RlIdent ProjectRoleR GET DELETE POST
/pr/#RlIdent/a ProjectRoleOpsR GET POST
/pr/#RlIdent/a/!new ProjectRoleOpNewR GET
/s/#ShrIdent/pr ProjectRolesR GET POST
/s/#ShrIdent/pr/!new ProjectRoleNewR GET
/s/#ShrIdent/pr/#RlIdent ProjectRoleR GET DELETE POST
/s/#ShrIdent/pr/#RlIdent/a ProjectRoleOpsR GET POST
/s/#ShrIdent/pr/#RlIdent/a/!new ProjectRoleOpNewR GET
-- ----------------------------------------------------------------------------
-- Projects

93
src/Vervis/Foundation.hs
View file

@ -122,25 +122,25 @@ instance Yesod App where
isAuthorized r w = case (r, w) of
(GroupsR , True) -> personAny
(GroupNewR , _ ) -> personAny
(GroupMembersR grp , True) -> groupRole (== GRAdmin) grp
(GroupMemberNewR grp , _ ) -> groupRole (== GRAdmin) grp
(GroupMemberR grp _memb , True) -> groupRole (== GRAdmin) grp
(GroupMembersR grp , True) -> groupAdmin grp
(GroupMemberNewR grp , _ ) -> groupAdmin grp
(GroupMemberR grp _memb , True) -> groupAdmin grp
(KeysR , _ ) -> personAny
(KeyR _key , _ ) -> personAny
(KeyNewR , _ ) -> personAny
(RepoRolesR , _ ) -> personAny
(RepoRoleNewR , _ ) -> personAny
(RepoRoleR _rl , _ ) -> personAny
(RepoRoleOpsR _rl , _ ) -> personAny
(RepoRoleOpNewR _rl , _ ) -> 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 , _ ) -> personAny
(ProjectRoleNewR , _ ) -> personAny
(ProjectRoleR _rl , _ ) -> personAny
(ProjectRoleOpsR _rl , _ ) -> personAny
(ProjectRoleOpNewR _rl , _ ) -> personAny
(ProjectRolesR shr , _ ) -> personOrGroupAdmin shr
(ProjectRoleNewR shr , _ ) -> personOrGroupAdmin shr
(ProjectRoleR shr _rl , _ ) -> personOrGroupAdmin shr
(ProjectRoleOpsR shr _rl , _ ) -> personOrGroupAdmin shr
(ProjectRoleOpNewR shr _rl , _ ) -> personOrGroupAdmin shr
(ReposR shar , True) -> person shar
(RepoNewR user , _ ) -> person user
@ -205,6 +205,43 @@ instance Yesod App where
then Authorized
else Unauthorized "Not the expected group role"
groupAdmin :: ShrIdent -> Handler AuthResult
groupAdmin = groupRole (== GRAdmin)
personOrGroupAdmin :: ShrIdent -> Handler AuthResult
personOrGroupAdmin shr = personAnd $ \ (Entity vpid _vp) -> runDB $ do
mes <- getBy $ UniqueSharer shr
case mes of
Nothing -> return $ Unauthorized "No such sharer"
Just (Entity sid _) -> do
mep <- getBy $ UniquePersonIdent sid
case mep of
Just (Entity pid _p) ->
return $ if pid == vpid
then Authorized
else
Unauthorized
"Can’t access other people’s roles"
Nothing -> do
meg <- getBy $ UniqueGroup sid
case meg of
Nothing -> do
$logWarn $
"Found non-person non-group \
\sharer: " <> shr2text shr
return $ Unauthorized "Zombine sharer"
Just (Entity gid _g) -> do
mem <- getBy $ UniqueGroupMember vpid gid
return $ case mem of
Nothing ->
Unauthorized "Not a group member"
Just (Entity _mid m) ->
if groupMemberRole m == GRAdmin
then Authorized
else
Unauthorized
"Not a group admin"
projOp
:: ProjectOperation -> ShrIdent -> PrjIdent -> Handler AuthResult
projOp op shr prj = personAnd $ \ (Entity pid _p) -> do
@ -333,17 +370,27 @@ instance YesodBreadcrumbs App where
KeyNewR -> ("New", Just KeysR)
KeyR key -> (ky2text key, Just KeysR)
RepoRolesR -> ("Repo Roles", Just HomeR)
RepoRoleNewR -> ("New", Just RepoRolesR)
RepoRoleR rl -> (rl2text rl, Just RepoRolesR)
RepoRoleOpsR rl -> ("Operations", Just $ RepoRoleR rl)
RepoRoleOpNewR rl -> ("New", Just $ RepoRoleOpsR rl)
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 -> ("Project Roles", Just HomeR)
ProjectRoleNewR -> ("New", Just ProjectRolesR)
ProjectRoleR rl -> (rl2text rl, Just ProjectRolesR)
ProjectRoleOpsR rl -> ("Operations", Just $ ProjectRoleR rl)
ProjectRoleOpNewR rl -> ("New", Just $ ProjectRoleOpsR rl)
ProjectRolesR shr -> ( "Project Roles"
, Just $ SharerR shr
)
ProjectRoleNewR shr -> ("New", Just $ ProjectRolesR shr)
ProjectRoleR shr rl -> ( rl2text rl
, Just $ ProjectRolesR shr
)
ProjectRoleOpsR shr rl -> ( "Operations"
, Just $ ProjectRoleR shr rl
)
ProjectRoleOpNewR shr rl -> ( "New"
, Just $ ProjectRoleOpsR shr rl
)
ReposR shar -> ("Repos", Just $ PersonR shar)
RepoNewR shar -> ("New", Just $ ReposR shar)

146
src/Vervis/Handler/Role.hs
View file

@ -49,21 +49,19 @@ import Yesod.Persist.Core (runDB, getBy404)
import Vervis.Form.Role
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident (RlIdent, rl2text)
import Vervis.Model.Ident (ShrIdent, RlIdent, rl2text)
import Vervis.Settings (widgetFile)
getRepoRolesR :: Handler Html
getRepoRolesR = do
pid <- requireAuthId
getRepoRolesR :: ShrIdent -> Handler Html
getRepoRolesR shr = do
roles <- runDB $ do
person <- getJust pid
selectList [RepoRoleSharer ==. personIdent person] []
Entity sid _ <- getBy404 $ UniqueSharer shr
selectList [RepoRoleSharer ==. sid] []
defaultLayout $(widgetFile "repo/role/list")
postRepoRolesR :: Handler Html
postRepoRolesR = do
pid <- requireAuthId
sid <- fmap personIdent $ runDB $ getJust pid
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
@ -74,7 +72,7 @@ postRepoRolesR = do
, repoRoleDesc = nrrDesc nrr
}
insert_ role
redirect $ RepoRolesR
redirect $ RepoRolesR shr
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/role/new")
@ -82,53 +80,48 @@ postRepoRolesR = do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "repo/role/new")
getRepoRoleNewR :: Handler Html
getRepoRoleNewR = do
pid <- requireAuthId
sid <- fmap personIdent $ runDB $ getJust pid
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 :: RlIdent -> Handler Html
getRepoRoleR rl = do
pid <- requireAuthId
sid <- fmap personIdent $ runDB $ getJust pid
Entity _rid role <- runDB $ getBy404 $ UniqueRepoRole sid rl
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 :: RlIdent -> Handler Html
deleteRepoRoleR rl = do
pid <- requireAuthId
deleteRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
deleteRepoRoleR shr rl = do
runDB $ do
person <- getJust pid
let sid = personIdent person
Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
delete rid
setMessage "Role deleted."
redirect RepoRolesR
redirect $ RepoRolesR shr
postRepoRoleR :: RlIdent -> Handler Html
postRepoRoleR rl = do
postRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
postRepoRoleR shr rl = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "DELETE" -> deleteRepoRoleR rl
Just "DELETE" -> deleteRepoRoleR shr rl
_ -> notFound
getRepoRoleOpsR :: RlIdent -> Handler Html
getRepoRoleOpsR rl = do
pid <- requireAuthId
getRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleOpsR shr rl = do
ops <- runDB $ do
sid <- personIdent <$> getJust pid
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 :: RlIdent -> Handler Html
postRepoRoleOpsR rl = do
pid <- requireAuthId
postRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
postRepoRoleOpsR shr rl = do
let getrid = do
sid <- personIdent <$> getJust pid
Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
case result of
@ -140,7 +133,7 @@ postRepoRoleOpsR rl = do
, repoAccessOp = op
}
insert_ access
redirect $ RepoRoleOpsR rl
redirect $ RepoRoleOpsR shr rl
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/role/op/new")
@ -148,27 +141,24 @@ postRepoRoleOpsR rl = do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "repo/role/op/new")
getRepoRoleOpNewR :: RlIdent -> Handler Html
getRepoRoleOpNewR rl = do
pid <- requireAuthId
getRepoRoleOpNewR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleOpNewR shr rl = do
let getrid = do
sid <- personIdent <$> getJust pid
Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
defaultLayout $(widgetFile "repo/role/op/new")
getProjectRolesR :: Handler Html
getProjectRolesR = do
pid <- requireAuthId
getProjectRolesR :: ShrIdent -> Handler Html
getProjectRolesR shr = do
roles <- runDB $ do
person <- getJust pid
selectList [ProjectRoleSharer ==. personIdent person] []
Entity sid _ <- getBy404 $ UniqueSharer shr
selectList [ProjectRoleSharer ==. sid] []
defaultLayout $(widgetFile "project/role/list")
postProjectRolesR :: Handler Html
postProjectRolesR = do
pid <- requireAuthId
sid <- fmap personIdent $ runDB $ getJust pid
postProjectRolesR :: ShrIdent -> Handler Html
postProjectRolesR shr = do
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
((result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
case result of
FormSuccess npr -> do
@ -179,7 +169,7 @@ postProjectRolesR = do
, projectRoleDesc = nprDesc npr
}
insert_ role
redirect $ ProjectRolesR
redirect $ ProjectRolesR shr
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "project/role/new")
@ -187,53 +177,48 @@ postProjectRolesR = do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "project/role/new")
getProjectRoleNewR :: Handler Html
getProjectRoleNewR = do
pid <- requireAuthId
sid <- fmap personIdent $ runDB $ getJust pid
getProjectRoleNewR :: ShrIdent -> Handler Html
getProjectRoleNewR shr = do
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
((_result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
defaultLayout $(widgetFile "project/role/new")
getProjectRoleR :: RlIdent -> Handler Html
getProjectRoleR rl = do
pid <- requireAuthId
getProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
getProjectRoleR shr rl = do
Entity _rid role <- runDB $ do
sid <- personIdent <$> getJust pid
Entity sid _ <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueProjectRole sid rl
defaultLayout $(widgetFile "project/role/one")
deleteProjectRoleR :: RlIdent -> Handler Html
deleteProjectRoleR rl = do
pid <- requireAuthId
deleteProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
deleteProjectRoleR shr rl = do
runDB $ do
sid <- personIdent <$> getJust pid
Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueProjectRole sid rl
delete rid
setMessage "Role deleted."
redirect ProjectRolesR
redirect $ ProjectRolesR shr
postProjectRoleR :: RlIdent -> Handler Html
postProjectRoleR rl = do
postProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
postProjectRoleR shr rl = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "DELETE" -> deleteProjectRoleR rl
Just "DELETE" -> deleteProjectRoleR shr rl
_ -> notFound
getProjectRoleOpsR :: RlIdent -> Handler Html
getProjectRoleOpsR rl = do
pid <- requireAuthId
getProjectRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
getProjectRoleOpsR shr rl = do
ops <- runDB $ do
sid <- personIdent <$> getJust pid
Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueProjectRole sid rl
as <- selectList [ProjectAccessRole ==. rid] []
return $ map (projectAccessOp . entityVal) as
defaultLayout $(widgetFile "project/role/op/list")
postProjectRoleOpsR :: RlIdent -> Handler Html
postProjectRoleOpsR rl = do
pid <- requireAuthId
postProjectRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
postProjectRoleOpsR shr rl = do
let getrid = do
sid <- personIdent <$> getJust pid
Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueProjectRole sid rl
((result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
case result of
@ -245,7 +230,7 @@ postProjectRoleOpsR rl = do
, projectAccessOp = op
}
insert_ access
redirect $ ProjectRoleOpsR rl
redirect $ ProjectRoleOpsR shr rl
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "project/role/op/new")
@ -253,11 +238,10 @@ postProjectRoleOpsR rl = do
setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "project/role/op/new")
getProjectRoleOpNewR :: RlIdent -> Handler Html
getProjectRoleOpNewR rl = do
pid <- requireAuthId
getProjectRoleOpNewR :: ShrIdent -> RlIdent -> Handler Html
getProjectRoleOpNewR shr rl = do
let getrid = do
sid <- personIdent <$> getJust pid
Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueProjectRole sid rl
((_result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
defaultLayout $(widgetFile "project/role/op/new")

4
templates/personal-overview.hamlet
View file

@ -34,9 +34,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<h2>Repository Roles
<p>
<a href=@{RepoRolesR}>Repository roles
<a href=@{RepoRolesR ident}>Repository roles
<h2>Project Roles
<p>
<a href=@{ProjectRolesR}>Project roles
<a href=@{ProjectRolesR ident}>Project roles

5
templates/project/role/list.hamlet
View file

@ -12,10 +12,11 @@ $# 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/>.
<a href=@{ProjectRoleNewR}>New…
<p>
<a href=@{ProjectRoleNewR shr}>New…
<ul>
$forall Entity _rid role <- roles
<li>
<a href=@{ProjectRoleR $ projectRoleIdent role}>
<a href=@{ProjectRoleR shr $ projectRoleIdent role}>
#{rl2text $ projectRoleIdent role}

2
templates/project/role/new.hamlet
View file

@ -12,6 +12,6 @@ $# 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=@{ProjectRolesR} enctype=#{enctype}>
<form method=POST action=@{ProjectRolesR shr} enctype=#{enctype}>
^{widget}
<input type=submit>

4
templates/project/role/one.hamlet
View file

@ -13,12 +13,12 @@ $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
<form method=POST action=@{ProjectRoleR rl}>
<form method=POST action=@{ProjectRoleR shr rl}>
<input type=hidden name=_method value=DELETE>
<input type=submit value="Delete this role">
<p>
<a href=@{ProjectRoleOpsR rl}>Operations
<a href=@{ProjectRoleOpsR shr rl}>Operations
<p>
#{projectRoleDesc role}

3
templates/project/role/op/list.hamlet
View file

@ -12,7 +12,8 @@ $# 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/>.
<a href=@{ProjectRoleOpNewR rl}>New…
<p>
<a href=@{ProjectRoleOpNewR shr rl}>New…
<ul>
$forall op <- ops

2
templates/project/role/op/new.hamlet
View file

@ -12,6 +12,6 @@ $# 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=@{ProjectRoleOpsR rl} enctype=#{enctype}>
<form method=POST action=@{ProjectRoleOpsR shr rl} enctype=#{enctype}>
^{widget}
<input type=submit>

6
templates/repo/role/list.hamlet
View file

@ -12,9 +12,11 @@ $# 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/>.
<a href=@{RepoRoleNewR}>New…
<p>
<a href=@{RepoRoleNewR shr}>New…
<ul>
$forall Entity _rid role <- roles
<li>
<a href=@{RepoRoleR $ repoRoleIdent role}>#{rl2text $ repoRoleIdent role}
<a href=@{RepoRoleR shr $ repoRoleIdent role}>
#{rl2text $ repoRoleIdent role}

2
templates/repo/role/new.hamlet
View file

@ -12,6 +12,6 @@ $# 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} enctype=#{enctype}>
<form method=POST action=@{RepoRolesR shr} enctype=#{enctype}>
^{widget}
<input type=submit>

4
templates/repo/role/one.hamlet
View file

@ -13,12 +13,12 @@ $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
<form method=POST action=@{RepoRoleR rl}>
<form method=POST action=@{RepoRoleR shr rl}>
<input type=hidden name=_method value=DELETE>
<input type=submit value="Delete this role">
<p>
<a href=@{RepoRoleOpsR rl}>Operations
<a href=@{RepoRoleOpsR shr rl}>Operations
<p>
#{repoRoleDesc role}

3
templates/repo/role/op/list.hamlet
View file

@ -12,7 +12,8 @@ $# 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/>.
<a href=@{RepoRoleOpNewR rl}>New…
<p>
<a href=@{RepoRoleOpNewR shr rl}>New…
<ul>
$forall op <- ops

2
templates/repo/role/op/new.hamlet
View file

@ -12,6 +12,6 @@ $# 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 rl} enctype=#{enctype}>
<form method=POST action=@{RepoRoleOpsR shr rl} enctype=#{enctype}>
^{widget}
<input type=submit>