From 5cba8389178110d58ba61c14a3209c384f8f8d3a Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 28 Jan 2019 14:43:07 +0000 Subject: [PATCH] Enable basic default project roles * When adding collaborators, you don't need a custom role. If you don't choose one, a basic default "developer" role will be used * If you don't assign a `ProjectCollabUser` role, a default "user" role is assumed for logged in users, otherwise a "guest" role * The "guest" role currently has no access at all * Theoretically there may also be a "maintainer" role allowing project sharers/maintainers to give maintainer-level access to more people, but right now maintainer role would be the same as developer so I haven't added it yet --- config/models | 2 +- src/Vervis/Access.hs | 49 +++++++++++++++++++--------- src/Vervis/Form/Project.hs | 12 +++---- src/Vervis/Handler/Project.hs | 37 +++++++++++---------- src/Vervis/Migration.hs | 2 ++ src/Vervis/Model/Role.hs | 2 +- templates/project/collab/list.hamlet | 10 ++++-- templates/project/collab/one.hamlet | 7 ++-- 8 files changed, 74 insertions(+), 47 deletions(-) diff --git a/config/models b/config/models index 5471c47..9aef13e 100644 --- a/config/models +++ b/config/models @@ -120,7 +120,7 @@ ProjectAccess ProjectCollab project ProjectId person PersonId - role ProjectRoleId + role ProjectRoleId Maybe UniqueProjectCollab project person diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index a36f688..9ecc750 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -65,6 +65,7 @@ import Control.Applicative ((<|>)) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader +import Data.Maybe (fromMaybe, isJust) import Database.Persist.Class (getBy) import Database.Persist.Sql (SqlBackend) import Database.Persist.Types (Entity (..)) @@ -119,6 +120,8 @@ checkRepoAccess mpid op shr rp = do roleHas role operation = getBy $ UniqueRepoAccess role operation ancestorHas = flip getRepoRoleAncestorWithOpQ +data PersonRole = Developer | User | Guest | RoleID ProjectRoleId + checkProjectAccess :: MonadIO m => Maybe PersonId @@ -134,28 +137,42 @@ checkProjectAccess mpid op shr prj = do case mjid of Nothing -> return NoSuchObject Just jid -> do - mpa <- runMaybeT $ do - rlid <- do - case mpid of - Just pid -> - MaybeT (asCollab jid pid) - <|> MaybeT (asUser jid) - <|> MaybeT (asAnon jid) - Nothing -> MaybeT $ asAnon jid - MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op) - return $ - case mpa of - Nothing -> ObjectAccessDenied - Just _ -> ObjectAccessAllowed + 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 asCollab jid pid = - fmap (projectCollabRole . entityVal) <$> + fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$> getBy (UniqueProjectCollab jid pid) asUser jid = - fmap (projectCollabUserRole . entityVal) <$> + fmap (RoleID . projectCollabUserRole . entityVal) <$> getBy (UniqueProjectCollabUser jid) asAnon jid = - fmap (projectCollabAnonRole . entityVal) <$> + fmap (RoleID . projectCollabAnonRole . entityVal) <$> getBy (UniqueProjectCollabAnon jid) roleHas role operation = getBy $ UniqueProjectAccess role operation ancestorHas = flip getProjectRoleAncestorWithOpQ + userAccess ProjOpOpenTicket = True + userAccess ProjOpAcceptTicket = False + userAccess ProjOpCloseTicket = False + userAccess ProjOpReopenTicket = False + userAccess ProjOpRequestTicket = True + userAccess ProjOpClaimTicket = False + userAccess ProjOpUnclaimTicket = True + userAccess ProjOpAssignTicket = False + userAccess ProjOpUnassignTicket = False + userAccess ProjOpAddTicketDep = False + userAccess ProjOpRemoveTicketDep = False + hasAccess Developer _ = pure True + hasAccess User op = pure $ userAccess op + hasAccess Guest _ = pure False + hasAccess (RoleID rlid) op = + fmap isJust . runMaybeT $ + MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op) + status True = ObjectAccessAllowed + status False = ObjectAccessDenied diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index a89161b..fcb3186 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Project.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -39,7 +39,7 @@ data NewProject = NewProject , npName :: Maybe Text , npDesc :: Maybe Text , npWflow :: WorkflowId - , npRole :: ProjectRoleId + , npRole :: Maybe ProjectRoleId } newProjectAForm :: SharerId -> AForm Handler NewProject @@ -48,7 +48,7 @@ newProjectAForm sid = NewProject <*> aopt textField "Name" Nothing <*> aopt textField "Description" Nothing <*> areq selectWorkflow "Workflow*" Nothing - <*> areq selectRole "Your role*" Nothing + <*> aopt selectRole "Custom role" Nothing where selectRole = selectField $ @@ -77,14 +77,14 @@ newProjectForm sid = renderDivs $ newProjectAForm sid data NewProjectCollab = NewProjectCollab { ncPerson :: PersonId - , ncRole :: ProjectRoleId + , ncRole :: Maybe ProjectRoleId } newProjectCollabAForm :: SharerId -> ProjectId -> AForm Handler NewProjectCollab newProjectCollabAForm sid jid = NewProjectCollab - <$> areq selectPerson "Person*" Nothing - <*> areq selectRole "Role*" Nothing + <$> areq selectPerson "Person*" Nothing + <*> aopt selectRole "Custom role" Nothing where selectPerson = selectField $ do l <- runDB $ select $ diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 2d71b5e..e716bf1 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -152,19 +152,21 @@ getProjectEditR shr prj = do defaultLayout $(widgetFile "project/edit") getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html -getProjectDevsR shr rp = do +getProjectDevsR shr prj = do devs <- runDB $ do - rid <- do - Entity s _ <- getBy404 $ UniqueSharer shr - Entity r _ <- getBy404 $ UniqueProject rp s - return r - select $ from $ \ (collab, person, sharer, role) -> do - where_ $ - collab ^. ProjectCollabProject E.==. val rid &&. - collab ^. ProjectCollabPerson E.==. person ^. PersonId &&. - person ^. PersonIdent E.==. sharer ^. SharerId &&. - collab ^. ProjectCollabRole E.==. role ^. ProjectRoleId - return (sharer, role ^. ProjectRoleIdent) + jid <- do + Entity sid _ <- getBy404 $ UniqueSharer shr + Entity jid _ <- getBy404 $ UniqueProject prj sid + return jid + select $ from $ \ (collab `InnerJoin` + person `InnerJoin` + sharer `LeftOuterJoin` + role) -> do + on $ collab ^. ProjectCollabRole E.==. role ?. ProjectRoleId + on $ person ^. PersonIdent E.==. sharer ^. SharerId + on $ collab ^. ProjectCollabPerson E.==. person ^. PersonId + where_ $ collab ^. ProjectCollabProject E.==. val jid + return (sharer, role ?. ProjectRoleIdent) defaultLayout $(widgetFile "project/collab/list") postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html @@ -202,19 +204,18 @@ getProjectDevNewR shr rp = do defaultLayout $(widgetFile "project/collab/new") getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html -getProjectDevR shr rp dev = do - rl <- runDB $ do +getProjectDevR shr prj dev = do + mrl <- runDB $ do jid <- do Entity s _ <- getBy404 $ UniqueSharer shr - Entity j _ <- getBy404 $ UniqueProject rp s + Entity j _ <- getBy404 $ UniqueProject prj s return j pid <- do Entity s _ <- getBy404 $ UniqueSharer dev Entity p _ <- getBy404 $ UniquePersonIdent s return p Entity _cid collab <- getBy404 $ UniqueProjectCollab jid pid - role <- getJust $ projectCollabRole collab - return $ projectRoleIdent role + fmap projectRoleIdent <$> traverse getJust (projectCollabRole collab) defaultLayout $(widgetFile "project/collab/one") deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 578553f..444e154 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -134,6 +134,8 @@ changes = , renameField "ProjectCollabUser" "repo" "project" -- 25 , addFieldPrimRequired "Person" ("" :: Text) "about" + -- 26 + , setFieldMaybe "ProjectCollab" "role" ] migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int)) diff --git a/src/Vervis/Model/Role.hs b/src/Vervis/Model/Role.hs index f6dbc6f..87c0311 100644 --- a/src/Vervis/Model/Role.hs +++ b/src/Vervis/Model/Role.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - diff --git a/templates/project/collab/list.hamlet b/templates/project/collab/list.hamlet index ad568ed..4d4c734 100644 --- a/templates/project/collab/list.hamlet +++ b/templates/project/collab/list.hamlet @@ -16,9 +16,13 @@ $# . Collaborator Role - $forall (Entity _sid sharer, Value rl) <- devs + $forall (Entity _sid sharer, Value mrl) <- devs ^{personLinkW sharer} - #{rl2text rl} + + $maybe rl <- mrl + #{rl2text rl} + $nothing + (Developer) -Add… +Add… diff --git a/templates/project/collab/one.hamlet b/templates/project/collab/one.hamlet index d16edc6..13389ea 100644 --- a/templates/project/collab/one.hamlet +++ b/templates/project/collab/one.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016 by fr33domlover . +$# Written in 2016, 2019 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -13,4 +13,7 @@ $# with this software. If not, see $# .

- Role: #{rl2text rl} + $maybe rl <- mrl + Role: #{rl2text rl} + $nothing + Role: (Developer)