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
This commit is contained in:
fr33domlover 2019-01-28 14:43:07 +00:00
parent dcadaed2ee
commit 5cba838917
8 changed files with 74 additions and 47 deletions

View file

@ -120,7 +120,7 @@ ProjectAccess
ProjectCollab ProjectCollab
project ProjectId project ProjectId
person PersonId person PersonId
role ProjectRoleId role ProjectRoleId Maybe
UniqueProjectCollab project person UniqueProjectCollab project person

View file

@ -65,6 +65,7 @@ import Control.Applicative ((<|>))
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Maybe (fromMaybe, isJust)
import Database.Persist.Class (getBy) import Database.Persist.Class (getBy)
import Database.Persist.Sql (SqlBackend) import Database.Persist.Sql (SqlBackend)
import Database.Persist.Types (Entity (..)) import Database.Persist.Types (Entity (..))
@ -119,6 +120,8 @@ checkRepoAccess mpid op shr rp = do
roleHas role operation = getBy $ UniqueRepoAccess role operation roleHas role operation = getBy $ UniqueRepoAccess role operation
ancestorHas = flip getRepoRoleAncestorWithOpQ ancestorHas = flip getRepoRoleAncestorWithOpQ
data PersonRole = Developer | User | Guest | RoleID ProjectRoleId
checkProjectAccess checkProjectAccess
:: MonadIO m :: MonadIO m
=> Maybe PersonId => Maybe PersonId
@ -134,28 +137,42 @@ checkProjectAccess mpid op shr prj = do
case mjid of case mjid of
Nothing -> return NoSuchObject Nothing -> return NoSuchObject
Just jid -> do Just jid -> do
mpa <- runMaybeT $ do role <- do
rlid <- do
case mpid of case mpid of
Just pid -> Just pid -> fmap (fromMaybe User) $ runMaybeT
MaybeT (asCollab jid pid) $ MaybeT (asCollab jid pid)
<|> MaybeT (asUser jid) <|> MaybeT (asUser jid)
<|> MaybeT (asAnon jid) <|> MaybeT (asAnon jid)
Nothing -> MaybeT $ asAnon jid Nothing -> fromMaybe Guest <$> asAnon jid
MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op) status <$> hasAccess role op
return $
case mpa of
Nothing -> ObjectAccessDenied
Just _ -> ObjectAccessAllowed
where where
asCollab jid pid = asCollab jid pid =
fmap (projectCollabRole . entityVal) <$> fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$>
getBy (UniqueProjectCollab jid pid) getBy (UniqueProjectCollab jid pid)
asUser jid = asUser jid =
fmap (projectCollabUserRole . entityVal) <$> fmap (RoleID . projectCollabUserRole . entityVal) <$>
getBy (UniqueProjectCollabUser jid) getBy (UniqueProjectCollabUser jid)
asAnon jid = asAnon jid =
fmap (projectCollabAnonRole . entityVal) <$> fmap (RoleID . projectCollabAnonRole . entityVal) <$>
getBy (UniqueProjectCollabAnon jid) getBy (UniqueProjectCollabAnon jid)
roleHas role operation = getBy $ UniqueProjectAccess role operation roleHas role operation = getBy $ UniqueProjectAccess role operation
ancestorHas = flip getProjectRoleAncestorWithOpQ 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

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 NewProject = NewProject
, npName :: Maybe Text , npName :: Maybe Text
, npDesc :: Maybe Text , npDesc :: Maybe Text
, npWflow :: WorkflowId , npWflow :: WorkflowId
, npRole :: ProjectRoleId , npRole :: Maybe ProjectRoleId
} }
newProjectAForm :: SharerId -> AForm Handler NewProject newProjectAForm :: SharerId -> AForm Handler NewProject
@ -48,7 +48,7 @@ newProjectAForm sid = NewProject
<*> aopt textField "Name" Nothing <*> aopt textField "Name" Nothing
<*> aopt textField "Description" Nothing <*> aopt textField "Description" Nothing
<*> areq selectWorkflow "Workflow*" Nothing <*> areq selectWorkflow "Workflow*" Nothing
<*> areq selectRole "Your role*" Nothing <*> aopt selectRole "Custom role" Nothing
where where
selectRole = selectRole =
selectField $ selectField $
@ -77,14 +77,14 @@ newProjectForm sid = renderDivs $ newProjectAForm sid
data NewProjectCollab = NewProjectCollab data NewProjectCollab = NewProjectCollab
{ ncPerson :: PersonId { ncPerson :: PersonId
, ncRole :: ProjectRoleId , ncRole :: Maybe ProjectRoleId
} }
newProjectCollabAForm newProjectCollabAForm
:: SharerId -> ProjectId -> AForm Handler NewProjectCollab :: SharerId -> ProjectId -> AForm Handler NewProjectCollab
newProjectCollabAForm sid jid = NewProjectCollab newProjectCollabAForm sid jid = NewProjectCollab
<$> areq selectPerson "Person*" Nothing <$> areq selectPerson "Person*" Nothing
<*> areq selectRole "Role*" Nothing <*> aopt selectRole "Custom role" Nothing
where where
selectPerson = selectField $ do selectPerson = selectField $ do
l <- runDB $ select $ l <- runDB $ select $

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.
- -
@ -152,19 +152,21 @@ getProjectEditR shr prj = do
defaultLayout $(widgetFile "project/edit") defaultLayout $(widgetFile "project/edit")
getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
getProjectDevsR shr rp = do getProjectDevsR shr prj = do
devs <- runDB $ do devs <- runDB $ do
rid <- do jid <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity r _ <- getBy404 $ UniqueProject rp s Entity jid _ <- getBy404 $ UniqueProject prj sid
return r return jid
select $ from $ \ (collab, person, sharer, role) -> do select $ from $ \ (collab `InnerJoin`
where_ $ person `InnerJoin`
collab ^. ProjectCollabProject E.==. val rid &&. sharer `LeftOuterJoin`
collab ^. ProjectCollabPerson E.==. person ^. PersonId &&. role) -> do
person ^. PersonIdent E.==. sharer ^. SharerId &&. on $ collab ^. ProjectCollabRole E.==. role ?. ProjectRoleId
collab ^. ProjectCollabRole E.==. role ^. ProjectRoleId on $ person ^. PersonIdent E.==. sharer ^. SharerId
return (sharer, role ^. ProjectRoleIdent) on $ collab ^. ProjectCollabPerson E.==. person ^. PersonId
where_ $ collab ^. ProjectCollabProject E.==. val jid
return (sharer, role ?. ProjectRoleIdent)
defaultLayout $(widgetFile "project/collab/list") defaultLayout $(widgetFile "project/collab/list")
postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
@ -202,19 +204,18 @@ getProjectDevNewR shr rp = do
defaultLayout $(widgetFile "project/collab/new") defaultLayout $(widgetFile "project/collab/new")
getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
getProjectDevR shr rp dev = do getProjectDevR shr prj dev = do
rl <- runDB $ do mrl <- runDB $ do
jid <- do jid <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject rp s Entity j _ <- getBy404 $ UniqueProject prj s
return j return j
pid <- do pid <- do
Entity s _ <- getBy404 $ UniqueSharer dev Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s Entity p _ <- getBy404 $ UniquePersonIdent s
return p return p
Entity _cid collab <- getBy404 $ UniqueProjectCollab jid pid Entity _cid collab <- getBy404 $ UniqueProjectCollab jid pid
role <- getJust $ projectCollabRole collab fmap projectRoleIdent <$> traverse getJust (projectCollabRole collab)
return $ projectRoleIdent role
defaultLayout $(widgetFile "project/collab/one") defaultLayout $(widgetFile "project/collab/one")
deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html

View file

@ -134,6 +134,8 @@ changes =
, renameField "ProjectCollabUser" "repo" "project" , renameField "ProjectCollabUser" "repo" "project"
-- 25 -- 25
, addFieldPrimRequired "Person" ("" :: Text) "about" , addFieldPrimRequired "Person" ("" :: Text) "about"
-- 26
, setFieldMaybe "ProjectCollab" "role"
] ]
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 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.
- -

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=@{ProjectDevNewR shr rp}>Add… <a href=@{ProjectDevNewR shr prj}>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)