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

151
src/Vervis/Foundation.hs
View file

@ -120,57 +120,57 @@ instance Yesod App where
-- Who can access which pages. -- Who can access which pages.
isAuthorized r w = case (r, w) of isAuthorized r w = case (r, w) of
(GroupsR , True) -> personAny (GroupsR , True) -> personAny
(GroupNewR , _ ) -> personAny (GroupNewR , _ ) -> personAny
(GroupMembersR grp , True) -> groupRole (== GRAdmin) grp (GroupMembersR grp , True) -> groupAdmin grp
(GroupMemberNewR grp , _ ) -> groupRole (== GRAdmin) grp (GroupMemberNewR grp , _ ) -> groupAdmin grp
(GroupMemberR grp _memb , True) -> groupRole (== GRAdmin) grp (GroupMemberR grp _memb , True) -> groupAdmin grp
(KeysR , _ ) -> personAny (KeysR , _ ) -> personAny
(KeyR _key , _ ) -> personAny (KeyR _key , _ ) -> personAny
(KeyNewR , _ ) -> personAny (KeyNewR , _ ) -> personAny
(RepoRolesR , _ ) -> personAny (RepoRolesR shr , _ ) -> personOrGroupAdmin shr
(RepoRoleNewR , _ ) -> personAny (RepoRoleNewR shr , _ ) -> personOrGroupAdmin shr
(RepoRoleR _rl , _ ) -> personAny (RepoRoleR shr _rl , _ ) -> personOrGroupAdmin shr
(RepoRoleOpsR _rl , _ ) -> personAny (RepoRoleOpsR shr _rl , _ ) -> personOrGroupAdmin shr
(RepoRoleOpNewR _rl , _ ) -> personAny (RepoRoleOpNewR shr _rl , _ ) -> personOrGroupAdmin shr
(ProjectRolesR , _ ) -> personAny (ProjectRolesR shr , _ ) -> personOrGroupAdmin shr
(ProjectRoleNewR , _ ) -> personAny (ProjectRoleNewR shr , _ ) -> personOrGroupAdmin shr
(ProjectRoleR _rl , _ ) -> personAny (ProjectRoleR shr _rl , _ ) -> personOrGroupAdmin shr
(ProjectRoleOpsR _rl , _ ) -> personAny (ProjectRoleOpsR shr _rl , _ ) -> personOrGroupAdmin shr
(ProjectRoleOpNewR _rl , _ ) -> personAny (ProjectRoleOpNewR shr _rl , _ ) -> personOrGroupAdmin shr
(ReposR shar , True) -> person shar (ReposR shar , True) -> person shar
(RepoNewR user , _ ) -> person user (RepoNewR user , _ ) -> person user
(RepoR shar _ , True) -> person shar (RepoR shar _ , True) -> person shar
(RepoEditR shr _rp , _ ) -> person shr (RepoEditR shr _rp , _ ) -> person shr
(RepoDevsR shr _rp , _ ) -> person shr (RepoDevsR shr _rp , _ ) -> person shr
(RepoDevNewR shr _rp , _ ) -> person shr (RepoDevNewR shr _rp , _ ) -> person shr
(RepoDevR shr _rp _dev , _ ) -> person shr (RepoDevR shr _rp _dev , _ ) -> person shr
(ProjectsR shar , True) -> person shar (ProjectsR shar , True) -> person shar
(ProjectNewR user , _ ) -> person user (ProjectNewR user , _ ) -> person user
(ProjectR shr _prj , True) -> person shr (ProjectR shr _prj , True) -> person shr
(ProjectEditR shr _prj , _ ) -> person shr (ProjectEditR shr _prj , _ ) -> person shr
(ProjectDevsR shr _prj , _ ) -> person shr (ProjectDevsR shr _prj , _ ) -> person shr
(ProjectDevNewR shr _prj , _ ) -> person shr (ProjectDevNewR shr _prj , _ ) -> person shr
(ProjectDevR shr _prj _dev , _ ) -> person shr (ProjectDevR shr _prj _dev , _ ) -> person shr
(TicketsR shar _ , True) -> person shar (TicketsR shar _ , True) -> person shar
(TicketNewR _ _ , _ ) -> personAny (TicketNewR _ _ , _ ) -> personAny
(TicketR user _ _ , True) -> person user (TicketR user _ _ , True) -> person user
(TicketEditR user _ _ , _ ) -> person user (TicketEditR user _ _ , _ ) -> person user
(TicketCloseR user _ _ , _ ) -> person user (TicketCloseR user _ _ , _ ) -> person user
(TicketOpenR user _ _ , _ ) -> person user (TicketOpenR user _ _ , _ ) -> person user
(TicketClaimR s j _ , _ ) -> projOp ProjOpClaimTicket s j (TicketClaimR s j _ , _ ) -> projOp ProjOpClaimTicket s j
(TicketUnclaimR s j _ , _ ) -> projOp ProjOpUnclaimTicket s j (TicketUnclaimR s j _ , _ ) -> projOp ProjOpUnclaimTicket s j
(TicketDiscussionR _ _ _ , True) -> personAny (TicketDiscussionR _ _ _ , True) -> personAny
(TicketMessageR _ _ _ _ , True) -> personAny (TicketMessageR _ _ _ _ , True) -> personAny
(TicketTopReplyR _ _ _ , _ ) -> personAny (TicketTopReplyR _ _ _ , _ ) -> personAny
(TicketReplyR _ _ _ _ , _ ) -> personAny (TicketReplyR _ _ _ _ , _ ) -> personAny
_ -> return Authorized _ -> return Authorized
where where
personAnd personAnd
:: (Entity Person -> Handler AuthResult) -> Handler AuthResult :: (Entity Person -> Handler AuthResult) -> Handler AuthResult
@ -205,6 +205,43 @@ instance Yesod App where
then Authorized then Authorized
else Unauthorized "Not the expected group role" 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 projOp
:: ProjectOperation -> ShrIdent -> PrjIdent -> Handler AuthResult :: ProjectOperation -> ShrIdent -> PrjIdent -> Handler AuthResult
projOp op shr prj = personAnd $ \ (Entity pid _p) -> do projOp op shr prj = personAnd $ \ (Entity pid _p) -> do
@ -333,17 +370,27 @@ instance YesodBreadcrumbs App where
KeyNewR -> ("New", Just KeysR) KeyNewR -> ("New", Just KeysR)
KeyR key -> (ky2text key, Just KeysR) KeyR key -> (ky2text key, Just KeysR)
RepoRolesR -> ("Repo Roles", Just HomeR) RepoRolesR shr -> ("Repo Roles", Just $ SharerR shr)
RepoRoleNewR -> ("New", Just RepoRolesR) RepoRoleNewR shr -> ("New", Just $ RepoRolesR shr)
RepoRoleR rl -> (rl2text rl, Just RepoRolesR) RepoRoleR shr rl -> (rl2text rl, Just $ RepoRolesR shr)
RepoRoleOpsR rl -> ("Operations", Just $ RepoRoleR rl) RepoRoleOpsR shr rl -> ( "Operations"
RepoRoleOpNewR rl -> ("New", Just $ RepoRoleOpsR rl) , Just $ RepoRoleR shr rl
)
RepoRoleOpNewR shr rl -> ("New", Just $ RepoRoleOpsR shr rl)
ProjectRolesR -> ("Project Roles", Just HomeR) ProjectRolesR shr -> ( "Project Roles"
ProjectRoleNewR -> ("New", Just ProjectRolesR) , Just $ SharerR shr
ProjectRoleR rl -> (rl2text rl, Just ProjectRolesR) )
ProjectRoleOpsR rl -> ("Operations", Just $ ProjectRoleR rl) ProjectRoleNewR shr -> ("New", Just $ ProjectRolesR shr)
ProjectRoleOpNewR rl -> ("New", Just $ ProjectRoleOpsR rl) 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) ReposR shar -> ("Repos", Just $ PersonR shar)
RepoNewR shar -> ("New", Just $ ReposR 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.Form.Role
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident (RlIdent, rl2text) import Vervis.Model.Ident (ShrIdent, RlIdent, rl2text)
import Vervis.Settings (widgetFile) import Vervis.Settings (widgetFile)
getRepoRolesR :: Handler Html getRepoRolesR :: ShrIdent -> Handler Html
getRepoRolesR = do getRepoRolesR shr = do
pid <- requireAuthId
roles <- runDB $ do roles <- runDB $ do
person <- getJust pid Entity sid _ <- getBy404 $ UniqueSharer shr
selectList [RepoRoleSharer ==. personIdent person] [] selectList [RepoRoleSharer ==. sid] []
defaultLayout $(widgetFile "repo/role/list") defaultLayout $(widgetFile "repo/role/list")
postRepoRolesR :: Handler Html postRepoRolesR :: ShrIdent -> Handler Html
postRepoRolesR = do postRepoRolesR shr = do
pid <- requireAuthId sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
sid <- fmap personIdent $ runDB $ getJust pid
((result, widget), enctype) <- runFormPost $ newRepoRoleForm sid ((result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
case result of case result of
FormSuccess nrr -> do FormSuccess nrr -> do
@ -74,7 +72,7 @@ postRepoRolesR = do
, repoRoleDesc = nrrDesc nrr , repoRoleDesc = nrrDesc nrr
} }
insert_ role insert_ role
redirect $ RepoRolesR redirect $ RepoRolesR shr
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/role/new") defaultLayout $(widgetFile "repo/role/new")
@ -82,53 +80,48 @@ postRepoRolesR = do
setMessage "Invalid input, see errors below" setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "repo/role/new") defaultLayout $(widgetFile "repo/role/new")
getRepoRoleNewR :: Handler Html getRepoRoleNewR :: ShrIdent -> Handler Html
getRepoRoleNewR = do getRepoRoleNewR shr = do
pid <- requireAuthId sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
sid <- fmap personIdent $ runDB $ getJust pid
((_result, widget), enctype) <- runFormPost $ newRepoRoleForm sid ((_result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
defaultLayout $(widgetFile "repo/role/new") defaultLayout $(widgetFile "repo/role/new")
getRepoRoleR :: RlIdent -> Handler Html getRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleR rl = do getRepoRoleR shr rl = do
pid <- requireAuthId Entity _rid role <- runDB $ do
sid <- fmap personIdent $ runDB $ getJust pid Entity sid _ <- getBy404 $ UniqueSharer shr
Entity _rid role <- runDB $ getBy404 $ UniqueRepoRole sid rl getBy404 $ UniqueRepoRole sid rl
defaultLayout $(widgetFile "repo/role/one") defaultLayout $(widgetFile "repo/role/one")
deleteRepoRoleR :: RlIdent -> Handler Html deleteRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
deleteRepoRoleR rl = do deleteRepoRoleR shr rl = do
pid <- requireAuthId
runDB $ do runDB $ do
person <- getJust pid Entity sid _s <- getBy404 $ UniqueSharer shr
let sid = personIdent person
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
delete rid delete rid
setMessage "Role deleted." setMessage "Role deleted."
redirect RepoRolesR redirect $ RepoRolesR shr
postRepoRoleR :: RlIdent -> Handler Html postRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
postRepoRoleR rl = do postRepoRoleR shr rl = do
mmethod <- lookupPostParam "_method" mmethod <- lookupPostParam "_method"
case mmethod of case mmethod of
Just "DELETE" -> deleteRepoRoleR rl Just "DELETE" -> deleteRepoRoleR shr rl
_ -> notFound _ -> notFound
getRepoRoleOpsR :: RlIdent -> Handler Html getRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleOpsR rl = do getRepoRoleOpsR shr rl = do
pid <- requireAuthId
ops <- runDB $ do ops <- runDB $ do
sid <- personIdent <$> getJust pid Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
as <- selectList [RepoAccessRole ==. rid] [] as <- selectList [RepoAccessRole ==. rid] []
return $ map (repoAccessOp . entityVal) as return $ map (repoAccessOp . entityVal) as
defaultLayout $(widgetFile "repo/role/op/list") defaultLayout $(widgetFile "repo/role/op/list")
postRepoRoleOpsR :: RlIdent -> Handler Html postRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
postRepoRoleOpsR rl = do postRepoRoleOpsR shr rl = do
pid <- requireAuthId
let getrid = do let getrid = do
sid <- personIdent <$> getJust pid Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid ((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
case result of case result of
@ -140,7 +133,7 @@ postRepoRoleOpsR rl = do
, repoAccessOp = op , repoAccessOp = op
} }
insert_ access insert_ access
redirect $ RepoRoleOpsR rl redirect $ RepoRoleOpsR shr rl
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"
defaultLayout $(widgetFile "repo/role/op/new") defaultLayout $(widgetFile "repo/role/op/new")
@ -148,27 +141,24 @@ postRepoRoleOpsR rl = do
setMessage "Invalid input, see errors below" setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "repo/role/op/new") defaultLayout $(widgetFile "repo/role/op/new")
getRepoRoleOpNewR :: RlIdent -> Handler Html getRepoRoleOpNewR :: ShrIdent -> RlIdent -> Handler Html
getRepoRoleOpNewR rl = do getRepoRoleOpNewR shr rl = do
pid <- requireAuthId
let getrid = do let getrid = do
sid <- personIdent <$> getJust pid Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid ((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
defaultLayout $(widgetFile "repo/role/op/new") defaultLayout $(widgetFile "repo/role/op/new")
getProjectRolesR :: Handler Html getProjectRolesR :: ShrIdent -> Handler Html
getProjectRolesR = do getProjectRolesR shr = do
pid <- requireAuthId
roles <- runDB $ do roles <- runDB $ do
person <- getJust pid Entity sid _ <- getBy404 $ UniqueSharer shr
selectList [ProjectRoleSharer ==. personIdent person] [] selectList [ProjectRoleSharer ==. sid] []
defaultLayout $(widgetFile "project/role/list") defaultLayout $(widgetFile "project/role/list")
postProjectRolesR :: Handler Html postProjectRolesR :: ShrIdent -> Handler Html
postProjectRolesR = do postProjectRolesR shr = do
pid <- requireAuthId sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
sid <- fmap personIdent $ runDB $ getJust pid
((result, widget), enctype) <- runFormPost $ newProjectRoleForm sid ((result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
case result of case result of
FormSuccess npr -> do FormSuccess npr -> do
@ -179,7 +169,7 @@ postProjectRolesR = do
, projectRoleDesc = nprDesc npr , projectRoleDesc = nprDesc npr
} }
insert_ role insert_ role
redirect $ ProjectRolesR redirect $ ProjectRolesR shr
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"
defaultLayout $(widgetFile "project/role/new") defaultLayout $(widgetFile "project/role/new")
@ -187,53 +177,48 @@ postProjectRolesR = do
setMessage "Invalid input, see errors below" setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "project/role/new") defaultLayout $(widgetFile "project/role/new")
getProjectRoleNewR :: Handler Html getProjectRoleNewR :: ShrIdent -> Handler Html
getProjectRoleNewR = do getProjectRoleNewR shr = do
pid <- requireAuthId sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
sid <- fmap personIdent $ runDB $ getJust pid
((_result, widget), enctype) <- runFormPost $ newProjectRoleForm sid ((_result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
defaultLayout $(widgetFile "project/role/new") defaultLayout $(widgetFile "project/role/new")
getProjectRoleR :: RlIdent -> Handler Html getProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
getProjectRoleR rl = do getProjectRoleR shr rl = do
pid <- requireAuthId
Entity _rid role <- runDB $ do Entity _rid role <- runDB $ do
sid <- personIdent <$> getJust pid Entity sid _ <- getBy404 $ UniqueSharer shr
getBy404 $ UniqueProjectRole sid rl getBy404 $ UniqueProjectRole sid rl
defaultLayout $(widgetFile "project/role/one") defaultLayout $(widgetFile "project/role/one")
deleteProjectRoleR :: RlIdent -> Handler Html deleteProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
deleteProjectRoleR rl = do deleteProjectRoleR shr rl = do
pid <- requireAuthId
runDB $ do runDB $ do
sid <- personIdent <$> getJust pid Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueProjectRole sid rl Entity rid _r <- getBy404 $ UniqueProjectRole sid rl
delete rid delete rid
setMessage "Role deleted." setMessage "Role deleted."
redirect ProjectRolesR redirect $ ProjectRolesR shr
postProjectRoleR :: RlIdent -> Handler Html postProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
postProjectRoleR rl = do postProjectRoleR shr rl = do
mmethod <- lookupPostParam "_method" mmethod <- lookupPostParam "_method"
case mmethod of case mmethod of
Just "DELETE" -> deleteProjectRoleR rl Just "DELETE" -> deleteProjectRoleR shr rl
_ -> notFound _ -> notFound
getProjectRoleOpsR :: RlIdent -> Handler Html getProjectRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
getProjectRoleOpsR rl = do getProjectRoleOpsR shr rl = do
pid <- requireAuthId
ops <- runDB $ do ops <- runDB $ do
sid <- personIdent <$> getJust pid Entity sid _s <- getBy404 $ UniqueSharer shr
Entity rid _r <- getBy404 $ UniqueProjectRole sid rl Entity rid _r <- getBy404 $ UniqueProjectRole sid rl
as <- selectList [ProjectAccessRole ==. rid] [] as <- selectList [ProjectAccessRole ==. rid] []
return $ map (projectAccessOp . entityVal) as return $ map (projectAccessOp . entityVal) as
defaultLayout $(widgetFile "project/role/op/list") defaultLayout $(widgetFile "project/role/op/list")
postProjectRoleOpsR :: RlIdent -> Handler Html postProjectRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
postProjectRoleOpsR rl = do postProjectRoleOpsR shr rl = do
pid <- requireAuthId
let getrid = do let getrid = do
sid <- personIdent <$> getJust pid Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueProjectRole sid rl fmap entityKey $ getBy404 $ UniqueProjectRole sid rl
((result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid ((result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
case result of case result of
@ -245,7 +230,7 @@ postProjectRoleOpsR rl = do
, projectAccessOp = op , projectAccessOp = op
} }
insert_ access insert_ access
redirect $ ProjectRoleOpsR rl redirect $ ProjectRoleOpsR shr rl
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"
defaultLayout $(widgetFile "project/role/op/new") defaultLayout $(widgetFile "project/role/op/new")
@ -253,11 +238,10 @@ postProjectRoleOpsR rl = do
setMessage "Invalid input, see errors below" setMessage "Invalid input, see errors below"
defaultLayout $(widgetFile "project/role/op/new") defaultLayout $(widgetFile "project/role/op/new")
getProjectRoleOpNewR :: RlIdent -> Handler Html getProjectRoleOpNewR :: ShrIdent -> RlIdent -> Handler Html
getProjectRoleOpNewR rl = do getProjectRoleOpNewR shr rl = do
pid <- requireAuthId
let getrid = do let getrid = do
sid <- personIdent <$> getJust pid Entity sid _ <- getBy404 $ UniqueSharer shr
fmap entityKey $ getBy404 $ UniqueProjectRole sid rl fmap entityKey $ getBy404 $ UniqueProjectRole sid rl
((_result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid ((_result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
defaultLayout $(widgetFile "project/role/op/new") 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 <h2>Repository Roles
<p> <p>
<a href=@{RepoRolesR}>Repository roles <a href=@{RepoRolesR ident}>Repository roles
<h2>Project Roles <h2>Project Roles
<p> <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 $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<a href=@{ProjectRoleNewR}>New… <p>
<a href=@{ProjectRoleNewR shr}>New…
<ul> <ul>
$forall Entity _rid role <- roles $forall Entity _rid role <- roles
<li> <li>
<a href=@{ProjectRoleR $ projectRoleIdent role}> <a href=@{ProjectRoleR shr $ projectRoleIdent role}>
#{rl2text $ 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 $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{ProjectRolesR} enctype=#{enctype}> <form method=POST action=@{ProjectRolesR shr} enctype=#{enctype}>
^{widget} ^{widget}
<input type=submit> <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/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div> <div>
<form method=POST action=@{ProjectRoleR rl}> <form method=POST action=@{ProjectRoleR shr rl}>
<input type=hidden name=_method value=DELETE> <input type=hidden name=_method value=DELETE>
<input type=submit value="Delete this role"> <input type=submit value="Delete this role">
<p> <p>
<a href=@{ProjectRoleOpsR rl}>Operations <a href=@{ProjectRoleOpsR shr rl}>Operations
<p> <p>
#{projectRoleDesc role} #{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 $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<a href=@{ProjectRoleOpNewR rl}>New… <p>
<a href=@{ProjectRoleOpNewR shr rl}>New…
<ul> <ul>
$forall op <- ops $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 $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <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} ^{widget}
<input type=submit> <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 $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<a href=@{RepoRoleNewR}>New… <p>
<a href=@{RepoRoleNewR shr}>New…
<ul> <ul>
$forall Entity _rid role <- roles $forall Entity _rid role <- roles
<li> <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 $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{RepoRolesR} enctype=#{enctype}> <form method=POST action=@{RepoRolesR shr} enctype=#{enctype}>
^{widget} ^{widget}
<input type=submit> <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/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div> <div>
<form method=POST action=@{RepoRoleR rl}> <form method=POST action=@{RepoRoleR shr rl}>
<input type=hidden name=_method value=DELETE> <input type=hidden name=_method value=DELETE>
<input type=submit value="Delete this role"> <input type=submit value="Delete this role">
<p> <p>
<a href=@{RepoRoleOpsR rl}>Operations <a href=@{RepoRoleOpsR shr rl}>Operations
<p> <p>
#{repoRoleDesc role} #{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 $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<a href=@{RepoRoleOpNewR rl}>New… <p>
<a href=@{RepoRoleOpNewR shr rl}>New…
<ul> <ul>
$forall op <- ops $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 $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <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} ^{widget}
<input type=submit> <input type=submit>