forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Enable basic default project roles

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

2
config/models
View file

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

49
src/Vervis/Access.hs
View file

@ -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

12
src/Vervis/Form/Project.hs
View file

@ -1,6 +1,6 @@
{- 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.
-
@ -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 $

37
src/Vervis/Handler/Project.hs
View file

@ -1,6 +1,6 @@
{- 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.
-
@ -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

2
src/Vervis/Migration.hs
View file

@ -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))

2
src/Vervis/Model/Role.hs
View file

@ -1,6 +1,6 @@
{- 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.
-

10
templates/project/collab/list.hamlet
View file

@ -16,9 +16,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<tr>
<th>Collaborator
<th>Role
$forall (Entity _sid sharer, Value rl) <- devs
$forall (Entity _sid sharer, Value mrl) <- devs
<tr>
<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…

7
templates/project/collab/one.hamlet
View file

@ -1,6 +1,6 @@
$# 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.
$#
@ -13,4 +13,7 @@ $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p>
Role: #{rl2text rl}
$maybe rl <- mrl
Role: #{rl2text rl}
$nothing
Role: (Developer)