From 23c06c535a71ce6e012a9124235eab82dd57698c Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 6 Jun 2016 19:41:22 +0000 Subject: [PATCH] Put roles under sharers, now groups' roles can be managed too --- config/routes | 20 ++-- src/Vervis/Foundation.hs | 151 +++++++++++++++++--------- src/Vervis/Handler/Role.hs | 146 +++++++++++-------------- templates/personal-overview.hamlet | 4 +- templates/project/role/list.hamlet | 5 +- templates/project/role/new.hamlet | 2 +- templates/project/role/one.hamlet | 4 +- templates/project/role/op/list.hamlet | 3 +- templates/project/role/op/new.hamlet | 2 +- templates/repo/role/list.hamlet | 6 +- templates/repo/role/new.hamlet | 2 +- templates/repo/role/one.hamlet | 4 +- templates/repo/role/op/list.hamlet | 3 +- templates/repo/role/op/new.hamlet | 2 +- 14 files changed, 195 insertions(+), 159 deletions(-) diff --git a/config/routes b/config/routes index a96f90a..72d1949 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index fc815cf..1a36078 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -120,57 +120,57 @@ instance Yesod App where -- Who can access which pages. 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 + (GroupsR , True) -> personAny + (GroupNewR , _ ) -> personAny + (GroupMembersR grp , True) -> groupAdmin grp + (GroupMemberNewR grp , _ ) -> groupAdmin grp + (GroupMemberR grp _memb , True) -> groupAdmin grp - (KeysR , _ ) -> personAny - (KeyR _key , _ ) -> personAny - (KeyNewR , _ ) -> personAny + (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 - (RepoR shar _ , True) -> person shar - (RepoEditR shr _rp , _ ) -> person shr - (RepoDevsR shr _rp , _ ) -> person shr - (RepoDevNewR shr _rp , _ ) -> person shr - (RepoDevR shr _rp _dev , _ ) -> person shr + (ReposR shar , True) -> person shar + (RepoNewR user , _ ) -> person user + (RepoR shar _ , True) -> person shar + (RepoEditR shr _rp , _ ) -> person shr + (RepoDevsR shr _rp , _ ) -> person shr + (RepoDevNewR shr _rp , _ ) -> person shr + (RepoDevR shr _rp _dev , _ ) -> person shr - (ProjectsR shar , True) -> person shar - (ProjectNewR user , _ ) -> person user - (ProjectR shr _prj , True) -> person shr - (ProjectEditR shr _prj , _ ) -> person shr + (ProjectsR shar , True) -> person shar + (ProjectNewR user , _ ) -> person user + (ProjectR shr _prj , True) -> person shr + (ProjectEditR shr _prj , _ ) -> person shr (ProjectDevsR shr _prj , _ ) -> person shr (ProjectDevNewR shr _prj , _ ) -> person shr (ProjectDevR shr _prj _dev , _ ) -> person shr - (TicketsR shar _ , True) -> person shar - (TicketNewR _ _ , _ ) -> personAny - (TicketR user _ _ , True) -> person user - (TicketEditR user _ _ , _ ) -> person user - (TicketCloseR user _ _ , _ ) -> person user - (TicketOpenR user _ _ , _ ) -> person user - (TicketClaimR s j _ , _ ) -> projOp ProjOpClaimTicket s j - (TicketUnclaimR s j _ , _ ) -> projOp ProjOpUnclaimTicket s j - (TicketDiscussionR _ _ _ , True) -> personAny - (TicketMessageR _ _ _ _ , True) -> personAny - (TicketTopReplyR _ _ _ , _ ) -> personAny - (TicketReplyR _ _ _ _ , _ ) -> personAny - _ -> return Authorized + (TicketsR shar _ , True) -> person shar + (TicketNewR _ _ , _ ) -> personAny + (TicketR user _ _ , True) -> person user + (TicketEditR user _ _ , _ ) -> person user + (TicketCloseR user _ _ , _ ) -> person user + (TicketOpenR user _ _ , _ ) -> person user + (TicketClaimR s j _ , _ ) -> projOp ProjOpClaimTicket s j + (TicketUnclaimR s j _ , _ ) -> projOp ProjOpUnclaimTicket s j + (TicketDiscussionR _ _ _ , True) -> personAny + (TicketMessageR _ _ _ _ , True) -> personAny + (TicketTopReplyR _ _ _ , _ ) -> personAny + (TicketReplyR _ _ _ _ , _ ) -> personAny + _ -> return Authorized where personAnd :: (Entity Person -> Handler AuthResult) -> Handler AuthResult @@ -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) diff --git a/src/Vervis/Handler/Role.hs b/src/Vervis/Handler/Role.hs index 9775bd0..d0ea50d 100644 --- a/src/Vervis/Handler/Role.hs +++ b/src/Vervis/Handler/Role.hs @@ -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") diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index b4dbad0..59abe74 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -34,9 +34,9 @@ $# .

Repository Roles

- Repository roles + Repository roles

Project Roles

- Project roles + Project roles diff --git a/templates/project/role/list.hamlet b/templates/project/role/list.hamlet index 01f9cda..43d38cc 100644 --- a/templates/project/role/list.hamlet +++ b/templates/project/role/list.hamlet @@ -12,10 +12,11 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -New… +

+ New…