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

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

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
+            role <- do
-                rlid <- do
+                case mpid of
-                    case mpid of
+                    Just pid -> fmap (fromMaybe User) $ runMaybeT
-                        Just pid ->
+                        $   MaybeT (asCollab jid pid)
-                                MaybeT (asCollab jid pid)
+                        <|> MaybeT (asUser jid)
-                            <|> MaybeT (asUser jid)
+                        <|> MaybeT (asAnon jid)
-                            <|> MaybeT (asAnon jid)
+                    Nothing -> fromMaybe Guest <$> asAnon jid
-                        Nothing -> MaybeT $ asAnon jid
+            status <$> hasAccess role op
-                MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
-            return $
-                case mpa of
-                    Nothing -> ObjectAccessDenied
-                    Just _  -> ObjectAccessAllowed
     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

src/Vervis/Form/Project.hs

@@ -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 selectPerson "Person*"     Nothing
-    <*> areq selectRole   "Role*"   Nothing
+    <*> aopt selectRole   "Custom role" Nothing
     where
     selectPerson = selectField $ do
         l <- runDB $ select $

src/Vervis/Handler/Project.hs

@@ -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
+        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")
 
 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
+getProjectDevR shr prj dev = do
-    rl <- runDB $ 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
+        fmap projectRoleIdent <$> traverse getJust (projectCollabRole collab)
-        return $ projectRoleIdent role
     defaultLayout $(widgetFile "project/collab/one")
 
 deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html

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

src/Vervis/Model/Role.hs

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

templates/project/collab/list.hamlet

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

templates/project/collab/one.hamlet

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